1 ! Copyright (C) 2006 Chris Double.
3 ! Redistribution and use in source and binary forms, with or without
4 ! modification, are permitted provided that the following conditions are met:
6 ! 1. Redistributions of source code must retain the above copyright notice,
7 ! this list of conditions and the following disclaimer.
9 ! 2. Redistributions in binary form must reproduce the above copyright notice,
10 ! this list of conditions and the following disclaimer in the documentation
11 ! and/or other materials provided with the distribution.
13 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
14 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
15 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
16 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
17 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
18 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
19 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
20 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
21 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
22 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
23 USING: kernel math sequences errors vectors prettyprint io
24 namespaces arrays words parser hashtables lazy-lists
25 kernel-internals parser-combinators strings ;
28 TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
30 GENERIC: reset ( cpu -- )
31 GENERIC: update-video ( value addr cpu -- )
32 GENERIC: read-port ( port cpu -- byte )
33 GENERIC: write-port ( value port cpu -- )
35 M: cpu update-video ( value addr cpu -- )
38 M: cpu read-port ( port cpu -- byte )
39 #! Read a byte from the hardware port. 'port' should
43 M: cpu write-port ( value port cpu -- )
44 #! Write a byte to the hardware port, where 'port' is
48 : carry-flag HEX: 01 ; inline
49 : parity-flag HEX: 04 ; inline
50 : half-carry-flag HEX: 10 ; inline
51 : interrupt-flag HEX: 20 ; inline
52 : zero-flag HEX: 40 ; inline
53 : sign-flag HEX: 80 ; inline
55 : >word< ( word -- byte byte )
56 #! Explode a word into its two 8 bit values.
57 dup HEX: FF bitand swap -8 shift HEX: FF bitand swap ;
59 : cpu-af ( cpu -- word )
60 #! Return the 16-bit pseudo register AF.
61 [ cpu-a 8 shift ] keep cpu-f bitor ;
63 : set-cpu-af ( value cpu -- )
64 #! Set the value of the 16-bit pseudo register AF
65 >r >word< r> tuck set-cpu-f set-cpu-a ;
67 : cpu-bc ( cpu -- word )
68 #! Return the 16-bit pseudo register BC.
69 [ cpu-b 8 shift ] keep cpu-c bitor ;
71 : set-cpu-bc ( value cpu -- )
72 #! Set the value of the 16-bit pseudo register BC
73 >r >word< r> tuck set-cpu-c set-cpu-b ;
75 : cpu-de ( cpu -- word )
76 #! Return the 16-bit pseudo register DE.
77 [ cpu-d 8 shift ] keep cpu-e bitor ;
79 : set-cpu-de ( value cpu -- )
80 #! Set the value of the 16-bit pseudo register DE
81 >r >word< r> tuck set-cpu-e set-cpu-d ;
83 : cpu-hl ( cpu -- word )
84 #! Return the 16-bit pseudo register HL.
85 [ cpu-h 8 shift ] keep cpu-l bitor ;
87 : set-cpu-hl ( value cpu -- )
88 #! Set the value of the 16-bit pseudo register HL
89 >r >word< r> tuck set-cpu-l set-cpu-h ;
91 : flag-set? ( flag cpu -- bool )
92 cpu-f bitand 0 = not ;
94 : flag-clear? ( flag cpu -- bool )
97 : flag-nz? ( cpu -- bool )
99 cpu-f zero-flag bitand 0 = ;
101 : flag-z? ( cpu -- bool )
103 cpu-f zero-flag bitand 0 = not ;
105 : flag-nc? ( cpu -- bool )
107 cpu-f carry-flag bitand 0 = ;
109 : flag-c? ( cpu -- bool )
111 cpu-f carry-flag bitand 0 = not ;
113 : flag-po? ( cpu -- bool )
115 cpu-f parity-flag bitand 0 = ;
117 : flag-pe? ( cpu -- bool )
119 cpu-f parity-flag bitand 0 = not ;
121 : flag-p? ( cpu -- bool )
123 cpu-f sign-flag bitand 0 = ;
125 : flag-m? ( cpu -- bool )
127 cpu-f sign-flag bitand 0 = not ;
129 : read-byte ( addr cpu -- byte )
130 #! Read one byte from memory at the specified address.
131 #! The address is 16-bit, but if a value greater than
132 #! 0xFFFF is provided then return a default value.
139 : read-word ( addr cpu -- word )
140 #! Read a 16-bit word from memory at the specified address.
141 #! The address is 16-bit, but if a value greater than
142 #! 0xFFFF is provided then return a default value.
143 [ read-byte ] 2keep >r 1 + r> read-byte 8 shift bitor ;
145 : next-byte ( cpu -- byte )
146 #! Return the value of the byte at PC, and increment PC.
152 : next-word ( cpu -- word )
153 #! Return the value of the word at PC, and increment PC.
160 : write-byte ( value addr cpu -- )
161 #! Write a byte to the specified memory address.
162 over dup HEX: 2000 < swap HEX: FFFF > or [
170 : write-word ( value addr cpu -- )
171 #! Write a 16-bit word to the specified memory address.
172 >r >r >word< r> r> [ write-byte ] 2keep >r 1 + r> write-byte ;
174 : cpu-a-bitand ( quot cpu -- )
176 [ cpu-a swap call bitand ] keep set-cpu-a ; inline
178 : cpu-a-bitor ( quot cpu -- )
180 [ cpu-a swap call bitor ] keep set-cpu-a ; inline
182 : cpu-a-bitxor ( quot cpu -- )
184 [ cpu-a swap call bitxor ] keep set-cpu-a ; inline
186 : cpu-a-bitxor= ( value cpu -- )
188 [ cpu-a bitxor ] keep set-cpu-a ;
190 : cpu-f-bitand ( quot cpu -- )
192 [ cpu-f swap call bitand ] keep set-cpu-f ; inline
194 : cpu-f-bitor ( quot cpu -- )
196 [ cpu-f swap call bitor ] keep set-cpu-f ; inline
198 : cpu-f-bitxor ( quot cpu -- )
200 [ cpu-f swap call bitxor ] keep set-cpu-f ; inline
202 : cpu-f-bitor= ( value cpu -- )
204 [ cpu-f bitor ] keep set-cpu-f ;
206 : cpu-f-bitand= ( value cpu -- )
208 [ cpu-f bitand ] keep set-cpu-f ;
210 : cpu-f-bitxor= ( value cpu -- )
212 [ cpu-f bitxor ] keep set-cpu-f ;
214 : set-flag ( cpu flag -- )
217 : clear-flag ( cpu flag -- )
218 bitnot HEX: FF bitand swap cpu-f-bitand= ;
220 : update-zero-flag ( result cpu -- )
221 #! If the result of an instruction has the value 0, this
222 #! flag is set, otherwise it is reset.
223 swap HEX: FF bitand 0 = [ zero-flag set-flag ] [ zero-flag clear-flag ] if ;
225 : update-sign-flag ( result cpu -- )
226 #! If the most significant bit of the result
227 #! has the value 1 then the flag is set, otherwise
229 swap HEX: 80 bitand 0 = [ sign-flag clear-flag ] [ sign-flag set-flag ] if ;
231 : update-parity-flag ( result cpu -- )
232 #! If the modulo 2 sum of the bits of the result
233 #! is 0, (ie. if the result has even parity) this flag
234 #! is set, otherwise it is reset.
235 swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] if ;
237 : update-carry-flag ( result cpu -- )
238 #! If the instruction resulted in a carry (from addition)
239 #! or a borrow (from subtraction or a comparison) out of the
240 #! higher order bit, this flag is set, otherwise it is reset.
241 swap dup HEX: 100 >= swap 0 < or [ carry-flag set-flag ] [ carry-flag clear-flag ] if ;
243 : update-half-carry-flag ( original change-by result cpu -- )
244 #! If the instruction caused a carry out of bit 3 and into bit 4 of the
245 #! resulting value, the half carry flag is set, otherwise it is reset.
246 #! The 'original' is the original value of the register being changed.
247 #! 'change-by' is the amount it is being added or decremented by.
248 #! 'result' is the result of that change.
249 >r bitxor bitxor HEX: 10 bitand 0 = not r>
250 swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ;
252 : update-flags ( result cpu -- )
253 2dup update-carry-flag
254 2dup update-parity-flag
255 2dup update-sign-flag
258 : update-flags-no-carry ( result cpu -- )
259 2dup update-parity-flag
260 2dup update-sign-flag
263 : add-byte ( lhs rhs cpu -- result )
265 >r 2dup + r> ! lhs rhs result cpu
266 [ update-flags ] 2keep
267 [ update-half-carry-flag ] 2keep
268 drop HEX: FF bitand ;
270 : add-carry ( change-by result cpu -- change-by result )
271 #! Add the effect of the carry flag to the result
272 flag-c? [ 1 + >r 1 + r> ] when ;
274 : add-byte-with-carry ( lhs rhs cpu -- result )
275 #! Add rhs to lhs plus carry.
276 >r 2dup + r> ! lhs rhs result cpu
278 [ update-flags ] 2keep
279 [ update-half-carry-flag ] 2keep
280 drop HEX: FF bitand ;
282 : sub-carry ( change-by result cpu -- change-by result )
283 #! Subtract the effect of the carry flag from the result
284 flag-c? [ 1 - >r 1 - r> ] when ;
286 : sub-byte ( lhs rhs cpu -- result )
287 #! Subtract rhs from lhs
289 [ update-flags ] 2keep
290 [ update-half-carry-flag ] 2keep
291 drop HEX: FF bitand ;
293 : sub-byte-with-carry ( lhs rhs cpu -- result )
294 #! Subtract rhs from lhs and take carry into account
297 [ update-flags ] 2keep
298 [ update-half-carry-flag ] 2keep
299 drop HEX: FF bitand ;
301 : inc-byte ( byte cpu -- result )
302 #! Increment byte by one. Note that carry flag is not affected
303 #! by this operation.
304 >r 1 2dup + r> ! lhs rhs result cpu
305 [ update-flags-no-carry ] 2keep
306 [ update-half-carry-flag ] 2keep
307 drop HEX: FF bitand ;
309 : dec-byte ( byte cpu -- result )
310 #! Decrement byte by one. Note that carry flag is not affected
311 #! by this operation.
312 >r 1 2dup - r> ! lhs rhs result cpu
313 [ update-flags-no-carry ] 2keep
314 [ update-half-carry-flag ] 2keep
315 drop HEX: FF bitand ;
317 : inc-word ( w cpu -- w )
318 #! Increment word by one. Note that no flags are modified.
319 drop 1 + HEX: FFFF bitand ;
321 : dec-word ( w cpu -- w )
322 #! Decrement word by one. Note that no flags are modified.
323 drop 1 - HEX: FFFF bitand ;
325 : add-word ( lhs rhs cpu -- result )
326 #! Add rhs to lhs. Note that only the carry flag is modified
327 #! and only if there is a carry out of the double precision add.
328 >r + r> over HEX: FFFF > [ carry-flag set-flag ] [ drop ] if HEX: FFFF bitand ;
330 : bit3or ( lhs rhs -- 0|1 )
331 #! bitor bit 3 of the two numbers on the stack
332 BIN: 00001000 bitand -3 shift >r
333 BIN: 00001000 bitand -3 shift r>
336 : and-byte ( lhs rhs cpu -- result )
337 #! Logically and rhs to lhs. The carry flag is cleared and
338 #! the half carry is set to the ORing of bits 3 of the operands.
339 [ drop bit3or ] 3keep ! bit3or lhs rhs cpu
340 >r bitand r> [ update-flags ] 2keep
341 [ carry-flag clear-flag ] keep
342 rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if
345 : xor-byte ( lhs rhs cpu -- result )
346 #! Logically xor rhs to lhs. The carry and half-carry flags are cleared.
347 >r bitxor r> [ update-flags ] 2keep
348 [ half-carry-flag carry-flag bitor clear-flag ] keep
349 drop HEX: FF bitand ;
351 : or-byte ( lhs rhs cpu -- result )
352 #! Logically or rhs to lhs. The carry and half-carry flags are cleared.
353 >r bitor r> [ update-flags ] 2keep
354 [ half-carry-flag carry-flag bitor clear-flag ] keep
355 drop HEX: FF bitand ;
357 : flags ( seq -- seq )
358 [ 0 [ execute bitor ] reduce ] map ;
360 : decrement-sp ( n cpu -- )
361 #! Decrement the stackpointer by n.
363 >r swap - r> set-cpu-sp ;
366 #! Save the value of the PC on the stack.
367 [ cpu-pc ] keep ! pc cpu
368 [ cpu-sp ] keep ! pc sp cpu
372 #! Push the value of the PC on the stack.
376 : pop-pc ( cpu -- pc )
377 #! Pop the value of the PC off the stack.
380 -2 swap decrement-sp ;
382 : push-sp ( value cpu -- )
383 [ 2 swap decrement-sp ] keep
387 : pop-sp ( cpu -- value )
390 -2 swap decrement-sp ;
392 : call-sub ( addr cpu -- )
393 #! Call the address as a subroutine.
395 >r HEX: FFFF bitand r> set-cpu-pc ;
397 : ret-from-sub ( cpu -- )
398 [ pop-pc ] keep set-cpu-pc ;
400 : interrupt ( number cpu -- )
401 #! Perform a hardware interrupt
402 ! "***Interrupt: " write over 16 >base print
403 dup cpu-f interrupt-flag bitand 0 = not [
410 : inc-cycles ( n cpu -- )
411 #! Increment the number of cpu cycles
412 [ cpu-cycles + ] keep set-cpu-cycles ;
414 : instruction-cycles ( -- vector )
415 #! Return a 256 element vector containing the cycles for
416 #! each opcode in the 8080 instruction set.
418 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
419 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
420 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
421 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
422 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
423 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
424 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
425 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ;
427 : instructions ( -- vector )
428 #! Return a 256 element vector containing the emulation words for
429 #! each opcode in the 8080 instruction set.
431 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
432 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
433 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
434 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
435 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
436 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
437 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
438 f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ; inline
440 : not-implemented ( <cpu> -- )
443 instructions length [
444 dup instructions nth [
447 [ not-implemented ] swap instructions set-nth
451 M: cpu reset ( cpu -- )
452 #! Reset the CPU to its poweron state
453 [ 0 swap set-cpu-b ] keep
454 [ 0 swap set-cpu-c ] keep
455 [ 0 swap set-cpu-d ] keep
456 [ 0 swap set-cpu-e ] keep
457 [ 0 swap set-cpu-h ] keep
458 [ 0 swap set-cpu-l ] keep
459 [ 0 swap set-cpu-a ] keep
460 [ 0 swap set-cpu-f ] keep
461 [ 0 swap set-cpu-pc ] keep
462 [ HEX: F000 swap set-cpu-sp ] keep
463 [ HEX: FFFF 0 <array> swap set-cpu-ram ] keep
464 [ f swap set-cpu-halted? ] keep
465 [ HEX: 10 swap set-cpu-last-interrupt ] keep
466 0 swap set-cpu-cycles ;
471 : (load-rom) ( n ram -- )
473 -rot [ set-nth ] 2keep >r 1 + r> (load-rom)
478 #! Reads the ROM from stdin and stores it in ROM from
480 : load-rom ( filename <cpu> -- )
481 #! Load the contents of the file into ROM.
482 #! (address 0x0000-0x1FFF).
483 cpu-ram swap <file-reader> [
487 : load-rom* ( addr filename <cpu> -- )
488 #! Load the contents of the file into ROM, starting at
489 #! the specified address.
490 cpu-ram swap <file-reader> [
494 : read-instruction ( cpu -- word )
495 #! Read the next instruction from the cpu's program
496 #! counter, and increment the program counter.
497 [ cpu-pc ] keep ! pc cpu
498 [ over 1 + swap set-cpu-pc ] keep
501 : get-cycles ( n -- opcode )
502 #! Returns the cycles for the given instruction value.
503 #! If the opcode is not defined throw an error.
504 dup instruction-cycles nth [
507 [ "Undefined 8080 opcode: " % number>string % ] "" make throw
510 : process-interrupts ( cpu -- )
511 #! Process any hardware interrupts
516 [ >r 16667 - r> set-cpu-cycles ] keep
517 dup cpu-last-interrupt HEX: 10 = [
518 HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt
520 HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt
525 #! Run a single 8080 instruction
526 [ read-instruction ] keep ! n cpu
527 over get-cycles over inc-cycles
528 [ swap instructions dispatch ] keep
529 [ cpu-pc HEX: FFFF bitand ] keep
533 : peek-instruction ( cpu -- word )
534 #! Return the next instruction from the cpu's program
535 #! counter, but don't increment the counter.
536 [ cpu-pc ] keep read-byte instructions nth first ;
539 [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
540 [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
541 [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
542 [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
543 [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
544 [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
545 [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
546 [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
547 [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
548 [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
549 [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
550 [ " " write peek-instruction word-name write " " write ] keep
554 [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
555 [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
556 [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
557 [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
558 [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
559 [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
560 [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
561 [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
562 [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
563 [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
564 [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
567 : test-step ( cpu -- cpu )
568 [ step ] keep dup cpu. ;
570 : test-cpu ( -- cpu )
571 <cpu> "invaders.rom" over load-rom dup cpu. ;
574 test-cpu swap [ test-step ] times ;
576 : run-n ( cpu n -- cpu )
579 : register-lookup ( string -- vector )
580 #! Given a string containing a register name, return a vector
581 #! where the 1st item is the getter and the 2nd is the setter
582 #! for that register.
584 { "A" { cpu-a set-cpu-a } }
585 { "B" { cpu-b set-cpu-b } }
586 { "C" { cpu-c set-cpu-c } }
587 { "D" { cpu-d set-cpu-d } }
588 { "E" { cpu-e set-cpu-e } }
589 { "H" { cpu-h set-cpu-h } }
590 { "L" { cpu-l set-cpu-l } }
591 { "AF" { cpu-af set-cpu-af } }
592 { "BC" { cpu-bc set-cpu-bc } }
593 { "DE" { cpu-de set-cpu-de } }
594 { "HL" { cpu-hl set-cpu-hl } }
595 { "SP" { cpu-sp set-cpu-sp } }
599 : flag-lookup ( string -- vector )
600 #! Given a string containing a flag name, return a vector
601 #! where the 1st item is a word that tests that flag.
603 { "NZ" { flag-nz? } }
604 { "NC" { flag-nc? } }
605 { "PO" { flag-po? } }
606 { "PE" { flag-pe? } }
618 : replace-patterns ( vector tree -- tree )
619 #! Copy the tree, replacing each occurence of
620 #! $1, $2, etc with the relevant item from the
622 dup quotation? over [ ] = not and [ ! vector tree
623 dup first swap 1 tail ! vector car cdr
624 >r dupd replace-patterns ! vector v R: cdr
625 swap r> replace-patterns >r unit r> append
627 dup $1 = [ drop 0 over nth ] when
628 dup $2 = [ drop 1 over nth ] when
629 dup $3 = [ drop 2 over nth ] when
630 dup $4 = [ drop 3 over nth ] when
635 { 4 5 3 } [ 1 $2 [ $1 4 ] ] replace-patterns ;
637 : (emulate-RST) ( n cpu -- )
639 [ cpu-sp 2 - dup ] keep ! sp sp cpu
640 [ set-cpu-sp ] keep ! sp cpu
641 [ cpu-pc ] keep ! sp pc cpu
642 swapd [ write-word ] keep ! cpu
643 >r 8 * r> set-cpu-pc ;
645 : (emulate-CALL) ( cpu -- )
647 [ next-word HEX: FFFF bitand ] keep ! addr cpu
648 [ cpu-sp 2 - dup ] keep ! addr sp sp cpu
649 [ set-cpu-sp ] keep ! addr sp cpu
650 [ cpu-pc ] keep ! addr sp pc cpu
651 swapd [ write-word ] keep ! addr cpu
654 : (emulate-RLCA) ( cpu -- )
655 #! The content of the accumulator is rotated left
656 #! one position. The low order bit and the carry flag
657 #! are both set to the value shifd out of the high
658 #! order bit position. Only the carry flag is affected.
659 [ cpu-a -7 shift ] keep
660 over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
661 [ cpu-a 1 shift HEX: FF bitand ] keep
662 >r bitor r> set-cpu-a ;
664 : (emulate-RRCA) ( cpu -- )
665 #! The content of the accumulator is rotated right
666 #! one position. The high order bit and the carry flag
667 #! are both set to the value shifd out of the low
668 #! order bit position. Only the carry flag is affected.
669 [ cpu-a 1 bitand 7 shift ] keep
670 over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
671 [ cpu-a 254 bitand -1 shift ] keep
672 >r bitor r> set-cpu-a ;
674 : (emulate-RLA) ( cpu -- )
675 #! The content of the accumulator is rotated left
676 #! one position through the carry flag. The low
677 #! order bit is set equal to the carry flag and
678 #! the carry flag is set to the value shifd out
679 #! of the high order bit. Only the carry flag is
681 [ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
682 [ cpu-a 127 bitand 7 shift ] keep
683 dup cpu-a 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
684 >r bitor r> set-cpu-a ;
686 : (emulate-RRA) ( cpu -- )
687 #! The content of the accumulator is rotated right
688 #! one position through the carry flag. The high order
689 #! bit is set to the carry flag and the carry flag is
690 #! set to the value shifd out of the low order bit.
691 #! Only the carry flag is affected.
692 [ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep
693 [ cpu-a 254 bitand -1 shift ] keep
694 dup cpu-a 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
695 >r bitor r> set-cpu-a ;
697 : (emulate-CPL) ( cpu -- )
698 #! The contents of the accumulator are complemented
699 #! (zero bits become one, one bits becomes zero).
700 #! No flags are affected.
701 HEX: FF swap cpu-a-bitxor= ;
703 : (emulate-DAA) ( cpu -- )
704 #! The eight bit number in the accumulator is
705 #! adjusted to form two four-bit binary-coded-decimal
708 dup half-carry-flag swap flag-set? swap
709 cpu-a BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] if
712 [ update-flags ] 2keep
713 [ swap HEX: FF bitand swap set-cpu-a ] keep
715 dup carry-flag swap flag-set? swap
716 cpu-a -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if
719 [ update-flags ] 2keep
720 swap HEX: FF bitand swap set-cpu-a ;
722 : patterns ( -- hashtable )
723 #! table of code quotation patterns for each type of instruction.
726 { "RET-NN" [ ret-from-sub ] }
727 { "RST-0" [ 0 swap (emulate-RST) ] }
728 { "RST-8" [ 8 swap (emulate-RST) ] }
729 { "RST-10H" [ HEX: 10 swap (emulate-RST) ] }
730 { "RST-18H" [ HEX: 18 swap (emulate-RST) ] }
731 { "RST-20H" [ HEX: 20 swap (emulate-RST) ] }
732 { "RST-28H" [ HEX: 28 swap (emulate-RST) ] }
733 { "RST-30H" [ HEX: 30 swap (emulate-RST) ] }
734 { "RST-38H" [ HEX: 38 swap (emulate-RST) ] }
735 { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
736 { "CP-N" [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] }
737 { "CP-R" [ [ cpu-a ] keep [ $1 ] keep sub-byte drop ] }
738 { "CP-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] }
739 { "OR-N" [ [ cpu-a ] keep [ next-byte ] keep [ or-byte ] keep set-cpu-a ] }
740 { "OR-R" [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] }
741 { "OR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a ] }
742 { "XOR-N" [ [ cpu-a ] keep [ next-byte ] keep [ xor-byte ] keep set-cpu-a ] }
743 { "XOR-R" [ [ cpu-a ] keep [ $1 ] keep [ xor-byte ] keep set-cpu-a ] }
744 { "XOR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep set-cpu-a ] }
745 { "AND-N" [ [ cpu-a ] keep [ next-byte ] keep [ and-byte ] keep set-cpu-a ] }
746 { "AND-R" [ [ cpu-a ] keep [ $1 ] keep [ and-byte ] keep set-cpu-a ] }
747 { "AND-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep set-cpu-a ] }
748 { "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] }
749 { "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] }
750 { "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] }
751 { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] }
752 { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] }
753 { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] }
754 { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] }
755 { "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
756 { "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] }
757 { "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
758 { "SUB-R" [ [ cpu-a ] keep [ $1 ] keep [ sub-byte ] keep set-cpu-a ] }
759 { "SUB-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep set-cpu-a ] }
760 { "SUB-N" [ [ cpu-a ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] }
761 { "CPL" [ (emulate-CPL) ] }
762 { "DAA" [ (emulate-DAA) ] }
763 { "RLA" [ (emulate-RLA) ] }
764 { "RRA" [ (emulate-RRA) ] }
765 { "CCF" [ carry-flag swap cpu-f-bitxor= ] }
766 { "SCF" [ carry-flag swap cpu-f-bitor= ] }
767 { "RLCA" [ (emulate-RLCA) ] }
768 { "RRCA" [ (emulate-RRCA) ] }
770 { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] }
771 { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] }
772 { "POP-RR" [ [ pop-sp ] keep $2 ] }
773 { "PUSH-RR" [ [ $1 ] keep push-sp ] }
774 { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] }
775 { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] }
776 { "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] }
777 { "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] }
778 { "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] }
779 { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] }
780 { "JP-NN" [ [ cpu-pc ] keep [ read-word ] keep set-cpu-pc ] }
781 { "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ set-cpu-pc ] keep [ cpu-cycles ] keep swap 5 + swap set-cpu-cycles ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] }
782 { "JP-(RR)" [ [ $1 ] keep set-cpu-pc ] }
783 { "CALL-NN" [ (emulate-CALL) ] }
784 { "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] }
785 { "LD-RR,NN" [ [ next-word ] keep $2 ] }
786 { "LD-RR,RR" [ [ $3 ] keep $2 ] }
787 { "LD-R,N" [ [ next-byte ] keep $2 ] }
788 { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] }
789 { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] }
790 { "LD-R,R" [ [ $3 ] keep $2 ] }
791 { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] }
792 { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] }
793 { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] }
794 { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] }
795 { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] }
796 { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] }
797 { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] }
798 { "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] }
799 { "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
802 : 8-bit-registers ( -- parser )
803 #! A parser for 8-bit registers. On a successfull parse the
804 #! parse tree contains a vector. The first item in the vector
805 #! is the getter word for that register with stack effect
806 #! ( cpu -- value ). The second item is the setter word with
807 #! stack effect ( value cpu -- ).
814 "L" token <|> [ register-lookup ] <@ ;
817 #! A parser for 16-bit flags.
825 "M" token <|> [ flag-lookup ] <@ ;
828 #! A parser for 16-bit registers. On a successfull parse the
829 #! parse tree contains a vector. The first item in the vector
830 #! is the getter word for that register with stack effect
831 #! ( cpu -- value ). The second item is the setter word with
832 #! stack effect ( value cpu -- ).
837 "SP" token <|> [ register-lookup ] <@ ;
839 : all-registers ( -- parser )
840 #! Return a parser that can parse the format
841 #! for 8 bit or 16 bit registers.
842 8-bit-registers 16-bit-registers <|> ;
844 : indirect ( parser -- parser )
845 #! Given a parser, return a parser which parses the original
846 #! wrapped in brackets, representing an indirect reference.
847 #! eg. BC -> (BC). The value of the original parser is left in
849 "(" token swap &> ")" token <& ;
851 : generate-instruction ( vector string -- quot )
852 #! Generate the quotation for an instruction, given the instruction in
853 #! the 'string' and a vector containing the arguments for that instruction.
854 patterns hash replace-patterns ;
856 : simple-instruction ( token -- parser )
857 #! Return a parser for then instruction identified by the token.
858 #! The parser return parses the token only and expects no additional
859 #! arguments to the instruction.
860 token [ [ { } clone , , \ generate-instruction , ] [ ] make ] <@ ;
862 : complex-instruction ( type token -- parser )
863 #! Return a parser for an instruction identified by the token.
864 #! The instruction is expected to take additional arguments by
865 #! being combined with other parsers. Then 'type' is used for a lookup
866 #! in a pattern hashtable to return the instruction quotation pattern.
867 token swap [ nip [ , \ generate-instruction , ] [ ] make ] curry <@ ;
869 : NOP-instruction ( -- parser )
870 "NOP" simple-instruction ;
872 : RET-NN-instruction ( -- parser )
873 "RET-NN" "RET" complex-instruction
875 just [ { } clone swap curry ] <@ ;
877 : RST-0-instruction ( -- parser )
878 "RST-0" "RST" complex-instruction
880 just [ { } clone swap curry ] <@ ;
882 : RST-8-instruction ( -- parser )
883 "RST-8" "RST" complex-instruction
885 just [ { } clone swap curry ] <@ ;
887 : RST-10H-instruction ( -- parser )
888 "RST-10H" "RST" complex-instruction
890 just [ { } clone swap curry ] <@ ;
892 : RST-18H-instruction ( -- parser )
893 "RST-18H" "RST" complex-instruction
895 just [ { } clone swap curry ] <@ ;
897 : RST-20H-instruction ( -- parser )
898 "RST-20H" "RST" complex-instruction
900 just [ { } clone swap curry ] <@ ;
902 : RST-28H-instruction ( -- parser )
903 "RST-28H" "RST" complex-instruction
905 just [ { } clone swap curry ] <@ ;
907 : RST-30H-instruction ( -- parser )
908 "RST-30H" "RST" complex-instruction
910 just [ { } clone swap curry ] <@ ;
912 : RST-38H-instruction ( -- parser )
913 "RST-38H" "RST" complex-instruction
915 just [ { } clone swap curry ] <@ ;
917 : JP-NN-instruction ( -- parser )
918 "JP-NN" "JP" complex-instruction
920 just [ { } clone swap curry ] <@ ;
922 : JP-F|FF,NN-instruction ( -- parser )
923 "JP-F|FF,NN" "JP" complex-instruction
926 just [ first2 swap curry ] <@ ;
928 : JP-(RR)-instruction ( -- parser )
929 "JP-(RR)" "JP" complex-instruction
930 16-bit-registers indirect sp <&>
931 just [ first2 swap curry ] <@ ;
933 : CALL-NN-instruction ( -- parser )
934 "CALL-NN" "CALL" complex-instruction
936 just [ { } clone swap curry ] <@ ;
938 : CALL-F|FF,NN-instruction ( -- parser )
939 "CALL-F|FF,NN" "CALL" complex-instruction
942 just [ first2 swap curry ] <@ ;
944 : RLCA-instruction ( -- parser )
945 "RLCA" simple-instruction ;
947 : RRCA-instruction ( -- parser )
948 "RRCA" simple-instruction ;
950 : HALT-instruction ( -- parser )
951 "HALT" simple-instruction ;
953 : DI-instruction ( -- parser )
954 "DI" simple-instruction ;
956 : EI-instruction ( -- parser )
957 "EI" simple-instruction ;
959 : CPL-instruction ( -- parser )
960 "CPL" simple-instruction ;
962 : CCF-instruction ( -- parser )
963 "CCF" simple-instruction ;
965 : SCF-instruction ( -- parser )
966 "SCF" simple-instruction ;
968 : DAA-instruction ( -- parser )
969 "DAA" simple-instruction ;
971 : RLA-instruction ( -- parser )
972 "RLA" simple-instruction ;
974 : RRA-instruction ( -- parser )
975 "RRA" simple-instruction ;
977 : DEC-R-instruction ( -- parser )
978 "DEC-R" "DEC" complex-instruction 8-bit-registers sp <&>
979 just [ first2 swap curry ] <@ ;
981 : DEC-RR-instruction ( -- parser )
982 "DEC-RR" "DEC" complex-instruction 16-bit-registers sp <&>
983 just [ first2 swap curry ] <@ ;
985 : DEC-(RR)-instruction ( -- parser )
986 "DEC-(RR)" "DEC" complex-instruction
987 16-bit-registers indirect sp <&>
988 just [ first2 swap curry ] <@ ;
990 : POP-RR-instruction ( -- parser )
991 "POP-RR" "POP" complex-instruction all-registers sp <&>
992 just [ first2 swap curry ] <@ ;
994 : PUSH-RR-instruction ( -- parser )
995 "PUSH-RR" "PUSH" complex-instruction all-registers sp <&>
996 just [ first2 swap curry ] <@ ;
998 : INC-R-instruction ( -- parser )
999 "INC-R" "INC" complex-instruction 8-bit-registers sp <&>
1000 just [ first2 swap curry ] <@ ;
1002 : INC-RR-instruction ( -- parser )
1003 "INC-RR" "INC" complex-instruction 16-bit-registers sp <&>
1004 just [ first2 swap curry ] <@ ;
1006 : INC-(RR)-instruction ( -- parser )
1007 "INC-(RR)" "INC" complex-instruction
1008 all-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1010 : RET-F|FF-instruction ( -- parser )
1011 "RET-F|FF" "RET" complex-instruction all-flags sp <&>
1012 just [ first2 swap curry ] <@ ;
1014 : AND-N-instruction ( -- parser )
1015 "AND-N" "AND" complex-instruction
1017 just [ { } clone swap curry ] <@ ;
1019 : AND-R-instruction ( -- parser )
1020 "AND-R" "AND" complex-instruction
1021 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
1023 : AND-(RR)-instruction ( -- parser )
1024 "AND-(RR)" "AND" complex-instruction
1025 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1027 : XOR-N-instruction ( -- parser )
1028 "XOR-N" "XOR" complex-instruction
1030 just [ { } clone swap curry ] <@ ;
1032 : XOR-R-instruction ( -- parser )
1033 "XOR-R" "XOR" complex-instruction
1034 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
1036 : XOR-(RR)-instruction ( -- parser )
1037 "XOR-(RR)" "XOR" complex-instruction
1038 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1040 : OR-N-instruction ( -- parser )
1041 "OR-N" "OR" complex-instruction
1043 just [ { } clone swap curry ] <@ ;
1045 : OR-R-instruction ( -- parser )
1046 "OR-R" "OR" complex-instruction
1047 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
1049 : OR-(RR)-instruction ( -- parser )
1050 "OR-(RR)" "OR" complex-instruction
1051 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1053 : CP-N-instruction ( -- parser )
1054 "CP-N" "CP" complex-instruction
1056 just [ { } clone swap curry ] <@ ;
1058 : CP-R-instruction ( -- parser )
1059 "CP-R" "CP" complex-instruction
1060 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
1062 : CP-(RR)-instruction ( -- parser )
1063 "CP-(RR)" "CP" complex-instruction
1064 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1066 : ADC-R,N-instruction ( -- parser )
1067 "ADC-R,N" "ADC" complex-instruction
1068 8-bit-registers sp <&>
1070 just [ first2 swap curry ] <@ ;
1072 : ADC-R,R-instruction ( -- parser )
1073 "ADC-R,R" "ADC" complex-instruction
1074 8-bit-registers sp <&>
1077 just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1079 : ADC-R,(RR)-instruction ( -- parser )
1080 "ADC-R,(RR)" "ADC" complex-instruction
1081 8-bit-registers sp <&>
1083 16-bit-registers indirect <&>
1084 just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1086 : SBC-R,N-instruction ( -- parser )
1087 "SBC-R,N" "SBC" complex-instruction
1088 8-bit-registers sp <&>
1090 just [ first2 swap curry ] <@ ;
1092 : SBC-R,R-instruction ( -- parser )
1093 "SBC-R,R" "SBC" complex-instruction
1094 8-bit-registers sp <&>
1097 just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1099 : SBC-R,(RR)-instruction ( -- parser )
1100 "SBC-R,(RR)" "SBC" complex-instruction
1101 8-bit-registers sp <&>
1103 16-bit-registers indirect <&>
1104 just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1106 : SUB-R-instruction ( -- parser )
1107 "SUB-R" "SUB" complex-instruction
1108 8-bit-registers sp <&>
1109 just [ first2 swap curry ] <@ ;
1111 : SUB-(RR)-instruction ( -- parser )
1112 "SUB-(RR)" "SUB" complex-instruction
1113 16-bit-registers indirect sp <&>
1114 just [ first2 swap curry ] <@ ;
1116 : SUB-N-instruction ( -- parser )
1117 "SUB-N" "SUB" complex-instruction
1119 just [ { } clone swap curry ] <@ ;
1121 : ADD-R,N-instruction ( -- parser )
1122 "ADD-R,N" "ADD" complex-instruction
1123 8-bit-registers sp <&>
1125 just [ first2 swap curry ] <@ ;
1127 : ADD-R,R-instruction ( -- parser )
1128 "ADD-R,R" "ADD" complex-instruction
1129 8-bit-registers sp <&>
1132 just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1134 : ADD-RR,RR-instruction ( -- parser )
1135 "ADD-RR,RR" "ADD" complex-instruction
1136 16-bit-registers sp <&>
1138 16-bit-registers <&>
1139 just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1141 : ADD-R,(RR)-instruction ( -- parser )
1142 "ADD-R,(RR)" "ADD" complex-instruction
1143 8-bit-registers sp <&>
1145 16-bit-registers indirect <&>
1146 just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1148 : LD-RR,NN-instruction
1150 "LD-RR,NN" "LD" complex-instruction
1151 16-bit-registers sp <&>
1153 just [ first2 swap curry ] <@ ;
1155 : LD-R,N-instruction
1157 "LD-R,N" "LD" complex-instruction
1158 8-bit-registers sp <&>
1160 just [ first2 swap curry ] <@ ;
1162 : LD-(RR),N-instruction
1163 "LD-(RR),N" "LD" complex-instruction
1164 16-bit-registers indirect sp <&>
1166 just [ first2 swap curry ] <@ ;
1168 : LD-(RR),R-instruction
1170 "LD-(RR),R" "LD" complex-instruction
1171 16-bit-registers indirect sp <&>
1174 just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1176 : LD-R,R-instruction
1177 "LD-R,R" "LD" complex-instruction
1178 8-bit-registers sp <&>
1181 just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1183 : LD-RR,RR-instruction
1184 "LD-RR,RR" "LD" complex-instruction
1185 16-bit-registers sp <&>
1187 16-bit-registers <&>
1188 just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1190 : LD-R,(RR)-instruction
1191 "LD-R,(RR)" "LD" complex-instruction
1192 8-bit-registers sp <&>
1194 16-bit-registers indirect <&>
1195 just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1197 : LD-(NN),RR-instruction
1198 "LD-(NN),RR" "LD" complex-instruction
1199 "nn" token indirect sp <&
1201 16-bit-registers <&>
1202 just [ first2 swap curry ] <@ ;
1204 : LD-(NN),R-instruction
1205 "LD-(NN),R" "LD" complex-instruction
1206 "nn" token indirect sp <&
1209 just [ first2 swap curry ] <@ ;
1211 : LD-RR,(NN)-instruction
1212 "LD-RR,(NN)" "LD" complex-instruction
1213 16-bit-registers sp <&>
1215 "nn" token indirect <&
1216 just [ first2 swap curry ] <@ ;
1218 : LD-R,(NN)-instruction
1219 "LD-R,(NN)" "LD" complex-instruction
1220 8-bit-registers sp <&>
1222 "nn" token indirect <&
1223 just [ first2 swap curry ] <@ ;
1225 : OUT-(N),R-instruction
1226 "OUT-(N),R" "OUT" complex-instruction
1227 "n" token indirect sp <&
1230 just [ first2 swap curry ] <@ ;
1232 : IN-R,(N)-instruction
1233 "IN-R,(N)" "IN" complex-instruction
1234 8-bit-registers sp <&>
1236 "n" token indirect <&
1237 just [ first2 swap curry ] <@ ;
1239 : EX-(RR),RR-instruction
1240 "EX-(RR),RR" "EX" complex-instruction
1241 16-bit-registers indirect sp <&>
1243 16-bit-registers <&>
1244 just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1246 : EX-RR,RR-instruction
1247 "EX-RR,RR" "EX" complex-instruction
1248 16-bit-registers sp <&>
1250 16-bit-registers <&>
1251 just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
1253 : 8080-generator-parser
1255 RST-0-instruction <|>
1256 RST-8-instruction <|>
1257 RST-10H-instruction <|>
1258 RST-18H-instruction <|>
1259 RST-20H-instruction <|>
1260 RST-28H-instruction <|>
1261 RST-30H-instruction <|>
1262 RST-38H-instruction <|>
1263 JP-F|FF,NN-instruction <|>
1264 JP-NN-instruction <|>
1265 JP-(RR)-instruction <|>
1266 CALL-F|FF,NN-instruction <|>
1267 CALL-NN-instruction <|>
1274 RLCA-instruction <|>
1275 RRCA-instruction <|>
1276 HALT-instruction <|>
1279 AND-N-instruction <|>
1280 AND-R-instruction <|>
1281 AND-(RR)-instruction <|>
1282 XOR-N-instruction <|>
1283 XOR-R-instruction <|>
1284 XOR-(RR)-instruction <|>
1285 OR-N-instruction <|>
1286 OR-R-instruction <|>
1287 OR-(RR)-instruction <|>
1288 CP-N-instruction <|>
1289 CP-R-instruction <|>
1290 CP-(RR)-instruction <|>
1291 DEC-RR-instruction <|>
1292 DEC-R-instruction <|>
1293 DEC-(RR)-instruction <|>
1294 POP-RR-instruction <|>
1295 PUSH-RR-instruction <|>
1296 INC-RR-instruction <|>
1297 INC-R-instruction <|>
1298 INC-(RR)-instruction <|>
1299 LD-RR,NN-instruction <|>
1300 LD-R,N-instruction <|>
1301 LD-R,R-instruction <|>
1302 LD-RR,RR-instruction <|>
1303 LD-(RR),N-instruction <|>
1304 LD-(RR),R-instruction <|>
1305 LD-R,(RR)-instruction <|>
1306 LD-(NN),RR-instruction <|>
1307 LD-(NN),R-instruction <|>
1308 LD-RR,(NN)-instruction <|>
1309 LD-R,(NN)-instruction <|>
1310 ADC-R,N-instruction <|>
1311 ADC-R,R-instruction <|>
1312 ADC-R,(RR)-instruction <|>
1313 ADD-R,N-instruction <|>
1314 ADD-R,R-instruction <|>
1315 ADD-RR,RR-instruction <|>
1316 ADD-R,(RR)-instruction <|>
1317 SBC-R,N-instruction <|>
1318 SBC-R,R-instruction <|>
1319 SBC-R,(RR)-instruction <|>
1320 SUB-R-instruction <|>
1321 SUB-(RR)-instruction <|>
1322 SUB-N-instruction <|>
1323 RET-F|FF-instruction <|>
1324 RET-NN-instruction <|>
1325 OUT-(N),R-instruction <|>
1326 IN-R,(N)-instruction <|>
1327 EX-(RR),RR-instruction <|>
1328 EX-RR,RR-instruction <|>
1331 : instruction-quotations ( string -- emulate-quot )
1332 #! Given an instruction string, return the emulation quotation for
1333 #! it. This will later be expanded to produce the disassembly and
1334 #! assembly quotations.
1335 8080-generator-parser some parse force call ;
1337 SYMBOL: last-instruction
1340 : parse-instructions ( list -- emulate-quot )
1341 #! Process the list of strings, which should make
1342 #! up an 8080 instruction, and output a quotation
1343 #! that would implement that instruction.
1344 dup " " join instruction-quotations
1345 >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-hash
1346 r> define-compound ;
1348 : INSTRUCTION: string-mode on [ string-mode off parse-instructions ] f ; parsing
1351 #! Set the number of cycles for the last instruction that was defined.
1352 scan string>number last-opcode global hash instruction-cycles set-nth ; parsing
1355 #! Set the opcode number for the last instruction that was defined.
1356 last-instruction global hash unit scan 16 base>
1357 dup last-opcode global set-hash instructions set-nth ; parsing
1359 INSTRUCTION: NOP ; opcode 00 cycles 04
1360 INSTRUCTION: LD BC,nn ; opcode 01 cycles 10
1361 INSTRUCTION: LD (BC),A ; opcode 02 cycles 07
1362 INSTRUCTION: INC BC ; opcode 03 cycles 06
1363 INSTRUCTION: INC B ; opcode 04 cycles 05
1364 INSTRUCTION: DEC B ; opcode 05 cycles 05
1365 INSTRUCTION: LD B,n ; opcode 06 cycles 07
1366 INSTRUCTION: RLCA ; opcode 07 cycles 04
1367 INSTRUCTION: NOP ; opcode 08 cycles 04
1368 INSTRUCTION: ADD HL,BC ; opcode 09 cycles 11
1369 INSTRUCTION: LD A,(BC) ; opcode 0A cycles 07
1370 INSTRUCTION: DEC BC ; opcode 0B cycles 06
1371 INSTRUCTION: INC C ; opcode 0C cycles 05
1372 INSTRUCTION: DEC C ; opcode 0D cycles 05
1373 INSTRUCTION: LD C,n ; opcode 0E cycles 07
1374 INSTRUCTION: RRCA ; opcode 0F cycles 04
1375 INSTRUCTION: LD DE,nn ; opcode 11 cycles 10
1376 INSTRUCTION: LD (DE),A ; opcode 12 cycles 07
1377 INSTRUCTION: INC DE ; opcode 13 cycles 06
1378 INSTRUCTION: INC D ; opcode 14 cycles 05
1379 INSTRUCTION: DEC D ; opcode 15 cycles 05
1380 INSTRUCTION: LD D,n ; opcode 16 cycles 07
1381 INSTRUCTION: RLA ; opcode 17 cycles 04
1382 INSTRUCTION: ADD HL,DE ; opcode 19 cycles 11
1383 INSTRUCTION: LD A,(DE) ; opcode 1A cycles 07
1384 INSTRUCTION: DEC DE ; opcode 1B cycles 06
1385 INSTRUCTION: INC E ; opcode 1C cycles 05
1386 INSTRUCTION: DEC E ; opcode 1D cycles 05
1387 INSTRUCTION: LD E,n ; opcode 1E cycles 07
1388 INSTRUCTION: RRA ; opcode 1F cycles 04
1389 INSTRUCTION: LD HL,nn ; opcode 21 cycles 10
1390 INSTRUCTION: LD (nn),HL ; opcode 22 cycles 16
1391 INSTRUCTION: INC HL ; opcode 23 cycles 06
1392 INSTRUCTION: INC H ; opcode 24 cycles 05
1393 INSTRUCTION: DEC H ; opcode 25 cycles 05
1394 INSTRUCTION: LD H,n ; opcode 26 cycles 07
1395 INSTRUCTION: DAA ; opcode 27 cycles 04
1396 INSTRUCTION: ADD HL,HL ; opcode 29 cycles 11
1397 INSTRUCTION: LD HL,(nn) ; opcode 2A cycles 16
1398 INSTRUCTION: DEC HL ; opcode 2B cycles 06
1399 INSTRUCTION: INC L ; opcode 2C cycles 05
1400 INSTRUCTION: DEC L ; opcode 2D cycles 05
1401 INSTRUCTION: LD L,n ; opcode 2E cycles 07
1402 INSTRUCTION: CPL ; opcode 2F cycles 04
1403 INSTRUCTION: LD SP,nn ; opcode 31 cycles 10
1404 INSTRUCTION: LD (nn),A ; opcode 32 cycles 13
1405 INSTRUCTION: INC SP ; opcode 33 cycles 06
1406 INSTRUCTION: INC (HL) ; opcode 34 cycles 10
1407 INSTRUCTION: DEC (HL) ; opcode 35 cycles 10
1408 INSTRUCTION: LD (HL),n ; opcode 36 cycles 10
1409 INSTRUCTION: SCF ; opcode 37 cycles 04
1410 INSTRUCTION: ADD HL,SP ; opcode 39 cycles 11
1411 INSTRUCTION: LD A,(nn) ; opcode 3A cycles 13
1412 INSTRUCTION: DEC SP ; opcode 3B cycles 06
1413 INSTRUCTION: INC A ; opcode 3C cycles 05
1414 INSTRUCTION: DEC A ; opcode 3D cycles 05
1415 INSTRUCTION: LD A,n ; opcode 3E cycles 07
1416 INSTRUCTION: CCF ; opcode 3F cycles 04
1417 INSTRUCTION: LD B,B ; opcode 40 cycles 05
1418 INSTRUCTION: LD B,C ; opcode 41 cycles 05
1419 INSTRUCTION: LD B,D ; opcode 42 cycles 05
1420 INSTRUCTION: LD B,E ; opcode 43 cycles 05
1421 INSTRUCTION: LD B,H ; opcode 44 cycles 05
1422 INSTRUCTION: LD B,L ; opcode 45 cycles 05
1423 INSTRUCTION: LD B,(HL) ; opcode 46 cycles 07
1424 INSTRUCTION: LD B,A ; opcode 47 cycles 05
1425 INSTRUCTION: LD C,B ; opcode 48 cycles 05
1426 INSTRUCTION: LD C,C ; opcode 49 cycles 05
1427 INSTRUCTION: LD C,D ; opcode 4A cycles 05
1428 INSTRUCTION: LD C,E ; opcode 4B cycles 05
1429 INSTRUCTION: LD C,H ; opcode 4C cycles 05
1430 INSTRUCTION: LD C,L ; opcode 4D cycles 05
1431 INSTRUCTION: LD C,(HL) ; opcode 4E cycles 07
1432 INSTRUCTION: LD C,A ; opcode 4F cycles 05
1433 INSTRUCTION: LD D,B ; opcode 50 cycles 05
1434 INSTRUCTION: LD D,C ; opcode 51 cycles 05
1435 INSTRUCTION: LD D,D ; opcode 52 cycles 05
1436 INSTRUCTION: LD D,E ; opcode 53 cycles 05
1437 INSTRUCTION: LD D,H ; opcode 54 cycles 05
1438 INSTRUCTION: LD D,L ; opcode 55 cycles 05
1439 INSTRUCTION: LD D,(HL) ; opcode 56 cycles 07
1440 INSTRUCTION: LD D,A ; opcode 57 cycles 05
1441 INSTRUCTION: LD E,B ; opcode 58 cycles 05
1442 INSTRUCTION: LD E,C ; opcode 59 cycles 05
1443 INSTRUCTION: LD E,D ; opcode 5A cycles 05
1444 INSTRUCTION: LD E,E ; opcode 5B cycles 05
1445 INSTRUCTION: LD E,H ; opcode 5C cycles 05
1446 INSTRUCTION: LD E,L ; opcode 5D cycles 05
1447 INSTRUCTION: LD E,(HL) ; opcode 5E cycles 07
1448 INSTRUCTION: LD E,A ; opcode 5F cycles 05
1449 INSTRUCTION: LD H,B ; opcode 60 cycles 05
1450 INSTRUCTION: LD H,C ; opcode 61 cycles 05
1451 INSTRUCTION: LD H,D ; opcode 62 cycles 05
1452 INSTRUCTION: LD H,E ; opcode 63 cycles 05
1453 INSTRUCTION: LD H,H ; opcode 64 cycles 05
1454 INSTRUCTION: LD H,L ; opcode 65 cycles 05
1455 INSTRUCTION: LD H,(HL) ; opcode 66 cycles 07
1456 INSTRUCTION: LD H,A ; opcode 67 cycles 05
1457 INSTRUCTION: LD L,B ; opcode 68 cycles 05
1458 INSTRUCTION: LD L,C ; opcode 69 cycles 05
1459 INSTRUCTION: LD L,D ; opcode 6A cycles 05
1460 INSTRUCTION: LD L,E ; opcode 6B cycles 05
1461 INSTRUCTION: LD L,H ; opcode 6C cycles 05
1462 INSTRUCTION: LD L,L ; opcode 6D cycles 05
1463 INSTRUCTION: LD L,(HL) ; opcode 6E cycles 07
1464 INSTRUCTION: LD L,A ; opcode 6F cycles 05
1465 INSTRUCTION: LD (HL),B ; opcode 70 cycles 07
1466 INSTRUCTION: LD (HL),C ; opcode 71 cycles 07
1467 INSTRUCTION: LD (HL),D ; opcode 72 cycles 07
1468 INSTRUCTION: LD (HL),E ; opcode 73 cycles 07
1469 INSTRUCTION: LD (HL),H ; opcode 74 cycles 07
1470 INSTRUCTION: LD (HL),L ; opcode 75 cycles 07
1471 INSTRUCTION: HALT ; opcode 76 cycles 07
1472 INSTRUCTION: LD (HL),A ; opcode 77 cycles 07
1473 INSTRUCTION: LD A,B ; opcode 78 cycles 05
1474 INSTRUCTION: LD A,C ; opcode 79 cycles 05
1475 INSTRUCTION: LD A,D ; opcode 7A cycles 05
1476 INSTRUCTION: LD A,E ; opcode 7B cycles 05
1477 INSTRUCTION: LD A,H ; opcode 7C cycles 05
1478 INSTRUCTION: LD A,L ; opcode 7D cycles 05
1479 INSTRUCTION: LD A,(HL) ; opcode 7E cycles 07
1480 INSTRUCTION: LD A,A ; opcode 7F cycles 05
1481 INSTRUCTION: ADD A,B ; opcode 80 cycles 04
1482 INSTRUCTION: ADD A,C ; opcode 81 cycles 04
1483 INSTRUCTION: ADD A,D ; opcode 82 cycles 04
1484 INSTRUCTION: ADD A,E ; opcode 83 cycles 04
1485 INSTRUCTION: ADD A,H ; opcode 84 cycles 04
1486 INSTRUCTION: ADD A,L ; opcode 85 cycles 04
1487 INSTRUCTION: ADD A,(HL) ; opcode 86 cycles 07
1488 INSTRUCTION: ADD A,A ; opcode 87 cycles 04
1489 INSTRUCTION: ADC A,B ; opcode 88 cycles 04
1490 INSTRUCTION: ADC A,C ; opcode 89 cycles 04
1491 INSTRUCTION: ADC A,D ; opcode 8A cycles 04
1492 INSTRUCTION: ADC A,E ; opcode 8B cycles 04
1493 INSTRUCTION: ADC A,H ; opcode 8C cycles 04
1494 INSTRUCTION: ADC A,L ; opcode 8D cycles 04
1495 INSTRUCTION: ADC A,(HL) ; opcode 8E cycles 07
1496 INSTRUCTION: ADC A,A ; opcode 8F cycles 04
1497 INSTRUCTION: SUB B ; opcode 90 cycles 04
1498 INSTRUCTION: SUB C ; opcode 91 cycles 04
1499 INSTRUCTION: SUB D ; opcode 92 cycles 04
1500 INSTRUCTION: SUB E ; opcode 93 cycles 04
1501 INSTRUCTION: SUB H ; opcode 94 cycles 04
1502 INSTRUCTION: SUB L ; opcode 95 cycles 04
1503 INSTRUCTION: SUB (HL) ; opcode 96 cycles 07
1504 INSTRUCTION: SUB A ; opcode 97 cycles 04
1505 INSTRUCTION: SBC A,B ; opcode 98 cycles 04
1506 INSTRUCTION: SBC A,C ; opcode 99 cycles 04
1507 INSTRUCTION: SBC A,D ; opcode 9A cycles 04
1508 INSTRUCTION: SBC A,E ; opcode 9B cycles 04
1509 INSTRUCTION: SBC A,H ; opcode 9C cycles 04
1510 INSTRUCTION: SBC A,L ; opcode 9D cycles 04
1511 INSTRUCTION: SBC A,(HL) ; opcode 9E cycles 07
1512 INSTRUCTION: SBC A,A ; opcode 9F cycles 04
1513 INSTRUCTION: AND B ; opcode A0 cycles 04
1514 INSTRUCTION: AND C ; opcode A1 cycles 04
1515 INSTRUCTION: AND D ; opcode A2 cycles 04
1516 INSTRUCTION: AND E ; opcode A3 cycles 04
1517 INSTRUCTION: AND H ; opcode A4 cycles 04
1518 INSTRUCTION: AND L ; opcode A5 cycles 04
1519 INSTRUCTION: AND (HL) ; opcode A6 cycles 07
1520 INSTRUCTION: AND A ; opcode A7 cycles 04
1521 INSTRUCTION: XOR B ; opcode A8 cycles 04
1522 INSTRUCTION: XOR C ; opcode A9 cycles 04
1523 INSTRUCTION: XOR D ; opcode AA cycles 04
1524 INSTRUCTION: XOR E ; opcode AB cycles 04
1525 INSTRUCTION: XOR H ; opcode AC cycles 04
1526 INSTRUCTION: XOR L ; opcode AD cycles 04
1527 INSTRUCTION: XOR (HL) ; opcode AE cycles 07
1528 INSTRUCTION: XOR A ; opcode AF cycles 04
1529 INSTRUCTION: OR B ; opcode B0 cycles 04
1530 INSTRUCTION: OR C ; opcode B1 cycles 04
1531 INSTRUCTION: OR D ; opcode B2 cycles 04
1532 INSTRUCTION: OR E ; opcode B3 cycles 04
1533 INSTRUCTION: OR H ; opcode B4 cycles 04
1534 INSTRUCTION: OR L ; opcode B5 cycles 04
1535 INSTRUCTION: OR (HL) ; opcode B6 cycles 07
1536 INSTRUCTION: OR A ; opcode B7 cycles 04
1537 INSTRUCTION: CP B ; opcode B8 cycles 04
1538 INSTRUCTION: CP C ; opcode B9 cycles 04
1539 INSTRUCTION: CP D ; opcode BA cycles 04
1540 INSTRUCTION: CP E ; opcode BB cycles 04
1541 INSTRUCTION: CP H ; opcode BC cycles 04
1542 INSTRUCTION: CP L ; opcode BD cycles 04
1543 INSTRUCTION: CP (HL) ; opcode BE cycles 07
1544 INSTRUCTION: CP A ; opcode BF cycles 04
1545 INSTRUCTION: RET NZ ; opcode C0 cycles 05
1546 INSTRUCTION: POP BC ; opcode C1 cycles 10
1547 INSTRUCTION: JP NZ,nn ; opcode C2 cycles 10
1548 INSTRUCTION: JP nn ; opcode C3 cycles 10
1549 INSTRUCTION: CALL NZ,nn ; opcode C4 cycles 11
1550 INSTRUCTION: PUSH BC ; opcode C5 cycles 11
1551 INSTRUCTION: ADD A,n ; opcode C6 cycles 07
1552 INSTRUCTION: RST 0 ; opcode C7 cycles 11
1553 INSTRUCTION: RET Z ; opcode C8 cycles 05
1554 INSTRUCTION: RET nn ; opcode C9 cycles 10
1555 INSTRUCTION: JP Z,nn ; opcode CA cycles 10
1556 INSTRUCTION: CALL Z,nn ; opcode CC cycles 11
1557 INSTRUCTION: CALL nn ; opcode CD cycles 17
1558 INSTRUCTION: ADC A,n ; opcode CE cycles 07
1559 INSTRUCTION: RST 8 ; opcode CF cycles 11
1560 INSTRUCTION: RET NC ; opcode D0 cycles 05
1561 INSTRUCTION: POP DE ; opcode D1 cycles 10
1562 INSTRUCTION: JP NC,nn ; opcode D2 cycles 10
1563 INSTRUCTION: OUT (n),A ; opcode D3 cycles 10
1564 INSTRUCTION: CALL NC,nn ; opcode D4 cycles 11
1565 INSTRUCTION: PUSH DE ; opcode D5 cycles 11
1566 INSTRUCTION: SUB n ; opcode D6 cycles 07
1567 INSTRUCTION: RST 10H ; opcode D7 cycles 11
1568 INSTRUCTION: RET C ; opcode D8 cycles 05
1569 INSTRUCTION: JP C,nn ; opcode DA cycles 10
1570 INSTRUCTION: IN A,(n) ; opcode DB cycles 10
1571 INSTRUCTION: CALL C,nn ; opcode DC cycles 11
1572 INSTRUCTION: SBC A,n ; opcode DE cycles 07
1573 INSTRUCTION: RST 18H ; opcode DF cycles 11
1574 INSTRUCTION: RET PO ; opcode E0 cycles 05
1575 INSTRUCTION: POP HL ; opcode E1 cycles 10
1576 INSTRUCTION: JP PO,nn ; opcode E2 cycles 10
1577 INSTRUCTION: EX (SP),HL ; opcode E3 cycles 04
1578 INSTRUCTION: CALL PO,nn ; opcode E4 cycles 11
1579 INSTRUCTION: PUSH HL ; opcode E5 cycles 11
1580 INSTRUCTION: AND n ; opcode E6 cycles 07
1581 INSTRUCTION: RST 20H ; opcode E7 cycles 11
1582 INSTRUCTION: RET PE ; opcode E8 cycles 05
1583 INSTRUCTION: JP (HL) ; opcode E9 cycles 04
1584 INSTRUCTION: JP PE,nn ; opcode EA cycles 10
1585 INSTRUCTION: EX DE,HL ; opcode EB cycles 04
1586 INSTRUCTION: CALL PE,nn ; opcode EC cycles 11
1587 INSTRUCTION: XOR n ; opcode EE cycles 07
1588 INSTRUCTION: RST 28H ; opcode EF cycles 11
1589 INSTRUCTION: RET P ; opcode F0 cycles 05
1590 INSTRUCTION: POP AF ; opcode F1 cycles 10
1591 INSTRUCTION: JP P,nn ; opcode F2 cycles 10
1592 INSTRUCTION: DI ; opcode F3 cycles 04
1593 INSTRUCTION: CALL P,nn ; opcode F4 cycles 11
1594 INSTRUCTION: PUSH AF ; opcode F5 cycles 11
1595 INSTRUCTION: OR n ; opcode F6 cycles 07
1596 INSTRUCTION: RST 30H ; opcode F7 cycles 11
1597 INSTRUCTION: RET M ; opcode F8 cycles 05
1598 INSTRUCTION: LD SP,HL ; opcode F9 cycles 06
1599 INSTRUCTION: JP M,nn ; opcode FA cycles 10
1600 INSTRUCTION: EI ; opcode FB cycles 04
1601 INSTRUCTION: CALL M,nn ; opcode FC cycles 11
1602 INSTRUCTION: CP n ; opcode FE cycles 07
1603 INSTRUCTION: RST 38H ; opcode FF cycles 11
1605 : each-8bit ( n quot -- )
1607 pick over -1 * shift 1 bitand pick call
1610 : >ppm ( cpu filename -- cpu )
1611 #! Dump the current screen image to a ppm image file with the given name.
1618 over 32 * over + HEX: 2400 + ! cpu h w addr
1619 >r pick r> swap cpu-ram nth [
1632 test-cpu [ 1000000 run-n ] time ;