1 ! Copyright (C) 2006 Chris Double.
2 ! See http://factorcode.org/license.txt for BSD license.
32 TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
34 GENERIC: reset ( cpu -- )
35 GENERIC: update-video ( value addr cpu -- )
36 GENERIC: read-port ( port cpu -- byte )
37 GENERIC: write-port ( value port cpu -- )
39 M: cpu update-video ( value addr cpu -- )
42 M: cpu read-port ( port cpu -- byte )
43 #! Read a byte from the hardware port. 'port' should
47 M: cpu write-port ( value port cpu -- )
48 #! Write a byte to the hardware port, where 'port' is
52 CONSTANT: carry-flag HEX: 01
53 CONSTANT: parity-flag HEX: 04
54 CONSTANT: half-carry-flag HEX: 10
55 CONSTANT: interrupt-flag HEX: 20
56 CONSTANT: zero-flag HEX: 40
57 CONSTANT: sign-flag HEX: 80
59 : >word< ( word -- byte byte )
60 #! Explode a word into its two 8 bit values.
61 dup HEX: FF bitand swap -8 shift HEX: FF bitand swap ;
63 : af>> ( cpu -- word )
64 #! Return the 16-bit pseudo register AF.
65 [ a>> 8 shift ] keep f>> bitor ;
67 : (>>af) ( value cpu -- )
68 #! Set the value of the 16-bit pseudo register AF
69 [ >word< ] dip swap >>f swap >>a drop ;
71 : bc>> ( cpu -- word )
72 #! Return the 16-bit pseudo register BC.
73 [ b>> 8 shift ] keep c>> bitor ;
75 : (>>bc) ( value cpu -- )
76 #! Set the value of the 16-bit pseudo register BC
77 [ >word< ] dip swap >>c swap >>b drop ;
79 : de>> ( cpu -- word )
80 #! Return the 16-bit pseudo register DE.
81 [ d>> 8 shift ] keep e>> bitor ;
83 : (>>de) ( value cpu -- )
84 #! Set the value of the 16-bit pseudo register DE
85 [ >word< ] dip swap >>e swap >>d drop ;
87 : hl>> ( cpu -- word )
88 #! Return the 16-bit pseudo register HL.
89 [ h>> 8 shift ] keep l>> bitor ;
91 : (>>hl) ( value cpu -- )
92 #! Set the value of the 16-bit pseudo register HL
93 [ >word< ] dip swap >>l swap >>h drop ;
95 : flag-set? ( flag cpu -- bool )
98 : flag-clear? ( flag cpu -- bool )
101 : flag-nz? ( cpu -- bool )
103 f>> zero-flag bitand 0 = ;
105 : flag-z? ( cpu -- bool )
107 f>> zero-flag bitand 0 = not ;
109 : flag-nc? ( cpu -- bool )
111 f>> carry-flag bitand 0 = ;
113 : flag-c? ( cpu -- bool )
115 f>> carry-flag bitand 0 = not ;
117 : flag-po? ( cpu -- bool )
119 f>> parity-flag bitand 0 = ;
121 : flag-pe? ( cpu -- bool )
123 f>> parity-flag bitand 0 = not ;
125 : flag-p? ( cpu -- bool )
127 f>> sign-flag bitand 0 = ;
129 : flag-m? ( cpu -- bool )
131 f>> sign-flag bitand 0 = not ;
133 : read-byte ( addr cpu -- byte )
134 #! Read one byte from memory at the specified address.
135 #! The address is 16-bit, but if a value greater than
136 #! 0xFFFF is provided then return a default value.
143 : read-word ( addr cpu -- word )
144 #! Read a 16-bit word from memory at the specified address.
145 #! The address is 16-bit, but if a value greater than
146 #! 0xFFFF is provided then return a default value.
147 [ read-byte ] 2keep [ 1 + ] dip read-byte 8 shift bitor ;
149 : next-byte ( cpu -- byte )
150 #! Return the value of the byte at PC, and increment PC.
156 : next-word ( cpu -- word )
157 #! Return the value of the word at PC, and increment PC.
164 : write-byte ( value addr cpu -- )
165 #! Write a byte to the specified memory address.
166 over dup HEX: 2000 < swap HEX: FFFF > or [
174 : write-word ( value addr cpu -- )
175 #! Write a 16-bit word to the specified memory address.
176 [ >word< ] 2dip [ write-byte ] 2keep [ 1 + ] dip write-byte ;
178 : cpu-a-bitand ( quot cpu -- )
180 [ a>> swap call bitand ] keep (>>a) ; inline
182 : cpu-a-bitor ( quot cpu -- )
184 [ a>> swap call bitor ] keep (>>a) ; inline
186 : cpu-a-bitxor ( quot cpu -- )
188 [ a>> swap call bitxor ] keep (>>a) ; inline
190 : cpu-a-bitxor= ( value cpu -- )
192 [ a>> bitxor ] keep (>>a) ;
194 : cpu-f-bitand ( quot cpu -- )
196 [ f>> swap call bitand ] keep (>>f) ; inline
198 : cpu-f-bitor ( quot cpu -- )
200 [ f>> swap call bitor ] keep (>>f) ; inline
202 : cpu-f-bitxor ( quot cpu -- )
204 [ f>> swap call bitxor ] keep (>>f) ; inline
206 : cpu-f-bitor= ( value cpu -- )
208 [ f>> bitor ] keep (>>f) ;
210 : cpu-f-bitand= ( value cpu -- )
212 [ f>> bitand ] keep (>>f) ;
214 : cpu-f-bitxor= ( value cpu -- )
216 [ f>> bitxor ] keep (>>f) ;
218 : set-flag ( cpu flag -- )
221 : clear-flag ( cpu flag -- )
222 bitnot HEX: FF bitand swap cpu-f-bitand= ;
224 : update-zero-flag ( result cpu -- )
225 #! If the result of an instruction has the value 0, this
226 #! flag is set, otherwise it is reset.
227 swap HEX: FF bitand 0 = [ zero-flag set-flag ] [ zero-flag clear-flag ] if ;
229 : update-sign-flag ( result cpu -- )
230 #! If the most significant bit of the result
231 #! has the value 1 then the flag is set, otherwise
233 swap HEX: 80 bitand 0 = [ sign-flag clear-flag ] [ sign-flag set-flag ] if ;
235 : update-parity-flag ( result cpu -- )
236 #! If the modulo 2 sum of the bits of the result
237 #! is 0, (ie. if the result has even parity) this flag
238 #! is set, otherwise it is reset.
239 swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] if ;
241 : update-carry-flag ( result cpu -- )
242 #! If the instruction resulted in a carry (from addition)
243 #! or a borrow (from subtraction or a comparison) out of the
244 #! higher order bit, this flag is set, otherwise it is reset.
245 swap dup HEX: 100 >= swap 0 < or [ carry-flag set-flag ] [ carry-flag clear-flag ] if ;
247 : update-half-carry-flag ( original change-by result cpu -- )
248 #! If the instruction caused a carry out of bit 3 and into bit 4 of the
249 #! resulting value, the half carry flag is set, otherwise it is reset.
250 #! The 'original' is the original value of the register being changed.
251 #! 'change-by' is the amount it is being added or decremented by.
252 #! 'result' is the result of that change.
253 [ bitxor bitxor HEX: 10 bitand 0 = not ] dip
254 swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ;
256 : update-flags ( result cpu -- )
257 2dup update-carry-flag
258 2dup update-parity-flag
259 2dup update-sign-flag
262 : update-flags-no-carry ( result cpu -- )
263 2dup update-parity-flag
264 2dup update-sign-flag
267 : add-byte ( lhs rhs cpu -- result )
270 [ update-flags ] 2keep
271 [ update-half-carry-flag ] 2keep
272 drop HEX: FF bitand ;
274 : add-carry ( change-by result cpu -- change-by result )
275 #! Add the effect of the carry flag to the result
276 flag-c? [ 1 + [ 1 + ] dip ] when ;
278 : add-byte-with-carry ( lhs rhs cpu -- result )
279 #! Add rhs to lhs plus carry.
282 [ update-flags ] 2keep
283 [ update-half-carry-flag ] 2keep
284 drop HEX: FF bitand ;
286 : sub-carry ( change-by result cpu -- change-by result )
287 #! Subtract the effect of the carry flag from the result
288 flag-c? [ 1 - [ 1 - ] dip ] when ;
290 : sub-byte ( lhs rhs cpu -- result )
291 #! Subtract rhs from lhs
293 [ update-flags ] 2keep
294 [ update-half-carry-flag ] 2keep
295 drop HEX: FF bitand ;
297 : sub-byte-with-carry ( lhs rhs cpu -- result )
298 #! Subtract rhs from lhs and take carry into account
301 [ update-flags ] 2keep
302 [ update-half-carry-flag ] 2keep
303 drop HEX: FF bitand ;
305 : inc-byte ( byte cpu -- result )
306 #! Increment byte by one. Note that carry flag is not affected
307 #! by this operation.
309 [ update-flags-no-carry ] 2keep
310 [ update-half-carry-flag ] 2keep
311 drop HEX: FF bitand ;
313 : dec-byte ( byte cpu -- result )
314 #! Decrement byte by one. Note that carry flag is not affected
315 #! by this operation.
317 [ update-flags-no-carry ] 2keep
318 [ update-half-carry-flag ] 2keep
319 drop HEX: FF bitand ;
321 : inc-word ( w cpu -- w )
322 #! Increment word by one. Note that no flags are modified.
323 drop 1 + HEX: FFFF bitand ;
325 : dec-word ( w cpu -- w )
326 #! Decrement word by one. Note that no flags are modified.
327 drop 1 - HEX: FFFF bitand ;
329 : add-word ( lhs rhs cpu -- result )
330 #! Add rhs to lhs. Note that only the carry flag is modified
331 #! and only if there is a carry out of the double precision add.
332 [ + ] dip over HEX: FFFF > [ carry-flag set-flag ] [ drop ] if HEX: FFFF bitand ;
334 : bit3or ( lhs rhs -- 0|1 )
335 #! bitor bit 3 of the two numbers on the stack
336 BIN: 00001000 bitand -3 shift [
337 BIN: 00001000 bitand -3 shift
341 : and-byte ( lhs rhs cpu -- result )
342 #! Logically and rhs to lhs. The carry flag is cleared and
343 #! the half carry is set to the ORing of bits 3 of the operands.
344 [ drop bit3or ] 3keep ! bit3or lhs rhs cpu
345 [ bitand ] dip [ update-flags ] 2keep
346 [ carry-flag clear-flag ] keep
347 rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if
350 : xor-byte ( lhs rhs cpu -- result )
351 #! Logically xor rhs to lhs. The carry and half-carry flags are cleared.
352 [ bitxor ] dip [ update-flags ] 2keep
353 [ half-carry-flag carry-flag bitor clear-flag ] keep
354 drop HEX: FF bitand ;
356 : or-byte ( lhs rhs cpu -- result )
357 #! Logically or rhs to lhs. The carry and half-carry flags are cleared.
358 [ bitor ] dip [ update-flags ] 2keep
359 [ half-carry-flag carry-flag bitor clear-flag ] keep
360 drop HEX: FF bitand ;
362 : decrement-sp ( n cpu -- )
363 #! Decrement the stackpointer by n.
365 [ swap - ] dip (>>sp) ;
368 #! Save the value of the PC on the stack.
369 [ pc>> ] keep ! pc cpu
370 [ sp>> ] keep ! pc sp cpu
374 #! Push the value of the PC on the stack.
378 : pop-pc ( cpu -- pc )
379 #! Pop the value of the PC off the stack.
382 -2 swap decrement-sp ;
384 : push-sp ( value cpu -- )
385 [ 2 swap decrement-sp ] keep
389 : pop-sp ( cpu -- value )
392 -2 swap decrement-sp ;
394 : call-sub ( addr cpu -- )
395 #! Call the address as a subroutine.
397 [ HEX: FFFF bitand ] dip (>>pc) ;
399 : ret-from-sub ( cpu -- )
400 [ pop-pc ] keep (>>pc) ;
402 : interrupt ( number cpu -- )
403 #! Perform a hardware interrupt
404 ! "***Interrupt: " write over 16 >base print
405 dup f>> interrupt-flag bitand 0 = not [
412 : inc-cycles ( n cpu -- )
413 #! Increment the number of cpu cycles
414 [ cycles>> + ] keep (>>cycles) ;
416 : instruction-cycles ( -- vector )
417 #! Return a 256 element vector containing the cycles for
418 #! each opcode in the 8080 instruction set.
419 \ instruction-cycles get-global [
420 256 f <array> \ instruction-cycles set-global
422 \ instruction-cycles get-global ;
424 : not-implemented ( <cpu> -- )
427 : instructions ( -- vector )
428 #! Return a 256 element vector containing the emulation words for
429 #! each opcode in the 8080 instruction set.
430 \ instructions get-global [
431 256 [ not-implemented ] <array> \ instructions set-global
433 \ instructions get-global ;
435 : set-instruction ( quot n -- )
436 instructions set-nth ;
438 M: cpu reset ( cpu -- )
439 #! Reset the CPU to its poweron state
450 HEX: FFFF 0 <array> >>ram
452 HEX: 10 >>last-interrupt
456 : <cpu> ( -- cpu ) cpu new dup reset ;
458 : (load-rom) ( n ram -- )
460 -rot [ set-nth ] 2keep [ 1 + ] dip (load-rom)
465 #! Reads the ROM from stdin and stores it in ROM from
467 : load-rom ( filename cpu -- )
468 #! Load the contents of the file into ROM.
469 #! (address 0x0000-0x1FFF).
476 : rom-dir ( -- string )
477 rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ;
479 : load-rom* ( seq cpu -- )
480 #! 'seq' is an array of arrays. Each array contains
481 #! an address and filename of a ROM file. The ROM
482 #! file will be loaded at the specified address. This
483 #! file path shoul dbe relative to the '/roms' resource path.
486 swap first2 rom-dir prepend-path binary [
493 "Set 'rom-root' to the path containing the root of the 8080 ROM files." throw
496 : read-instruction ( cpu -- word )
497 #! Read the next instruction from the cpu's program
498 #! counter, and increment the program counter.
499 [ pc>> ] keep ! pc cpu
500 [ over 1 + swap (>>pc) ] keep
503 : get-cycles ( n -- opcode )
504 #! Returns the cycles for the given instruction value.
505 #! If the opcode is not defined throw an error.
506 dup instruction-cycles nth [
509 [ "Undefined 8080 opcode: " % number>string % ] "" make throw
512 : process-interrupts ( cpu -- )
513 #! Process any hardware interrupts
518 [ [ 16667 - ] dip (>>cycles) ] keep
519 dup last-interrupt>> HEX: 10 = [
520 HEX: 08 over (>>last-interrupt) HEX: 08 swap interrupt
522 HEX: 10 over (>>last-interrupt) HEX: 10 swap interrupt
526 : peek-instruction ( cpu -- word )
527 #! Return the next instruction from the cpu's program
528 #! counter, but don't increment the counter.
529 [ pc>> ] keep read-byte instructions nth first ;
532 [ " PC: " write pc>> 16 >base 4 CHAR: \s pad-head write ] keep
533 [ " B: " write b>> 16 >base 2 CHAR: \s pad-head write ] keep
534 [ " C: " write c>> 16 >base 2 CHAR: \s pad-head write ] keep
535 [ " D: " write d>> 16 >base 2 CHAR: \s pad-head write ] keep
536 [ " E: " write e>> 16 >base 2 CHAR: \s pad-head write ] keep
537 [ " F: " write f>> 16 >base 2 CHAR: \s pad-head write ] keep
538 [ " H: " write h>> 16 >base 2 CHAR: \s pad-head write ] keep
539 [ " L: " write l>> 16 >base 2 CHAR: \s pad-head write ] keep
540 [ " A: " write a>> 16 >base 2 CHAR: \s pad-head write ] keep
541 [ " SP: " write sp>> 16 >base 4 CHAR: \s pad-head write ] keep
542 [ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ] keep
543 [ " " write peek-instruction name>> write " " write ] keep
547 [ " PC: " write pc>> 16 >base 4 CHAR: \s pad-head write ] keep
548 [ " B: " write b>> 16 >base 2 CHAR: \s pad-head write ] keep
549 [ " C: " write c>> 16 >base 2 CHAR: \s pad-head write ] keep
550 [ " D: " write d>> 16 >base 2 CHAR: \s pad-head write ] keep
551 [ " E: " write e>> 16 >base 2 CHAR: \s pad-head write ] keep
552 [ " F: " write f>> 16 >base 2 CHAR: \s pad-head write ] keep
553 [ " H: " write h>> 16 >base 2 CHAR: \s pad-head write ] keep
554 [ " L: " write l>> 16 >base 2 CHAR: \s pad-head write ] keep
555 [ " A: " write a>> 16 >base 2 CHAR: \s pad-head write ] keep
556 [ " SP: " write sp>> 16 >base 4 CHAR: \s pad-head write ] keep
557 [ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ] keep
560 : register-lookup ( string -- vector )
561 #! Given a string containing a register name, return a vector
562 #! where the 1st item is the getter and the 2nd is the setter
563 #! for that register.
565 { "A" { a>> (>>a) } }
566 { "B" { b>> (>>b) } }
567 { "C" { c>> (>>c) } }
568 { "D" { d>> (>>d) } }
569 { "E" { e>> (>>e) } }
570 { "H" { h>> (>>h) } }
571 { "L" { l>> (>>l) } }
572 { "AF" { af>> (>>af) } }
573 { "BC" { bc>> (>>bc) } }
574 { "DE" { de>> (>>de) } }
575 { "HL" { hl>> (>>hl) } }
576 { "SP" { sp>> (>>sp) } }
580 : flag-lookup ( string -- vector )
581 #! Given a string containing a flag name, return a vector
582 #! where the 1st item is a word that tests that flag.
584 { "NZ" { flag-nz? } }
585 { "NC" { flag-nc? } }
586 { "PO" { flag-po? } }
587 { "PE" { flag-pe? } }
594 SYMBOLS: $1 $2 $3 $4 ;
596 : replace-patterns ( vector tree -- tree )
607 : (emulate-RST) ( n cpu -- )
609 [ sp>> 2 - dup ] keep ! sp sp cpu
610 [ (>>sp) ] keep ! sp cpu
611 [ pc>> ] keep ! sp pc cpu
612 swapd [ write-word ] keep ! cpu
615 : (emulate-CALL) ( cpu -- )
617 [ next-word HEX: FFFF bitand ] keep ! addr cpu
618 [ sp>> 2 - dup ] keep ! addr sp sp cpu
619 [ (>>sp) ] keep ! addr sp cpu
620 [ pc>> ] keep ! addr sp pc cpu
621 swapd [ write-word ] keep ! addr cpu
624 : (emulate-RLCA) ( cpu -- )
625 #! The content of the accumulator is rotated left
626 #! one position. The low order bit and the carry flag
627 #! are both set to the value shifd out of the high
628 #! order bit position. Only the carry flag is affected.
629 [ a>> -7 shift ] keep
630 over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
631 [ a>> 1 shift HEX: FF bitand ] keep
632 [ bitor ] dip (>>a) ;
634 : (emulate-RRCA) ( cpu -- )
635 #! The content of the accumulator is rotated right
636 #! one position. The high order bit and the carry flag
637 #! are both set to the value shifd out of the low
638 #! order bit position. Only the carry flag is affected.
639 [ a>> 1 bitand 7 shift ] keep
640 over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
641 [ a>> 254 bitand -1 shift ] keep
642 [ bitor ] dip (>>a) ;
644 : (emulate-RLA) ( cpu -- )
645 #! The content of the accumulator is rotated left
646 #! one position through the carry flag. The low
647 #! order bit is set equal to the carry flag and
648 #! the carry flag is set to the value shifd out
649 #! of the high order bit. Only the carry flag is
651 [ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
652 [ a>> 127 bitand 7 shift ] keep
653 dup a>> 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
654 [ bitor ] dip (>>a) ;
656 : (emulate-RRA) ( cpu -- )
657 #! The content of the accumulator is rotated right
658 #! one position through the carry flag. The high order
659 #! bit is set to the carry flag and the carry flag is
660 #! set to the value shifd out of the low order bit.
661 #! Only the carry flag is affected.
662 [ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep
663 [ a>> 254 bitand -1 shift ] keep
664 dup a>> 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
665 [ bitor ] dip (>>a) ;
667 : (emulate-CPL) ( cpu -- )
668 #! The contents of the accumulator are complemented
669 #! (zero bits become one, one bits becomes zero).
670 #! No flags are affected.
671 HEX: FF swap cpu-a-bitxor= ;
673 : (emulate-DAA) ( cpu -- )
674 #! The eight bit number in the accumulator is
675 #! adjusted to form two four-bit binary-coded-decimal
678 dup half-carry-flag swap flag-set? swap
679 a>> BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] if
682 [ update-flags ] 2keep
683 [ swap HEX: FF bitand swap (>>a) ] keep
685 dup carry-flag swap flag-set? swap
686 a>> -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if
689 [ update-flags ] 2keep
690 swap HEX: FF bitand swap (>>a) ;
692 : patterns ( -- hashtable )
693 #! table of code quotation patterns for each type of instruction.
696 { "RET-NN" [ ret-from-sub ] }
697 { "RST-0" [ 0 swap (emulate-RST) ] }
698 { "RST-8" [ 8 swap (emulate-RST) ] }
699 { "RST-10H" [ HEX: 10 swap (emulate-RST) ] }
700 { "RST-18H" [ HEX: 18 swap (emulate-RST) ] }
701 { "RST-20H" [ HEX: 20 swap (emulate-RST) ] }
702 { "RST-28H" [ HEX: 28 swap (emulate-RST) ] }
703 { "RST-30H" [ HEX: 30 swap (emulate-RST) ] }
704 { "RST-38H" [ HEX: 38 swap (emulate-RST) ] }
705 { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
706 { "CP-N" [ [ a>> ] keep [ next-byte ] keep sub-byte drop ] }
707 { "CP-R" [ [ a>> ] keep [ $1 ] keep sub-byte drop ] }
708 { "CP-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] }
709 { "OR-N" [ [ a>> ] keep [ next-byte ] keep [ or-byte ] keep (>>a) ] }
710 { "OR-R" [ [ a>> ] keep [ $1 ] keep [ or-byte ] keep (>>a) ] }
711 { "OR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep (>>a) ] }
712 { "XOR-N" [ [ a>> ] keep [ next-byte ] keep [ xor-byte ] keep (>>a) ] }
713 { "XOR-R" [ [ a>> ] keep [ $1 ] keep [ xor-byte ] keep (>>a) ] }
714 { "XOR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep (>>a) ] }
715 { "AND-N" [ [ a>> ] keep [ next-byte ] keep [ and-byte ] keep (>>a) ] }
716 { "AND-R" [ [ a>> ] keep [ $1 ] keep [ and-byte ] keep (>>a) ] }
717 { "AND-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep (>>a) ] }
718 { "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] }
719 { "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] }
720 { "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] }
721 { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] }
722 { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] }
723 { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] }
724 { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] }
725 { "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
726 { "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] }
727 { "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
728 { "SUB-R" [ [ a>> ] keep [ $1 ] keep [ sub-byte ] keep (>>a) ] }
729 { "SUB-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep (>>a) ] }
730 { "SUB-N" [ [ a>> ] keep [ next-byte ] keep [ sub-byte ] keep (>>a) ] }
731 { "CPL" [ (emulate-CPL) ] }
732 { "DAA" [ (emulate-DAA) ] }
733 { "RLA" [ (emulate-RLA) ] }
734 { "RRA" [ (emulate-RRA) ] }
735 { "CCF" [ carry-flag swap cpu-f-bitxor= ] }
736 { "SCF" [ carry-flag swap cpu-f-bitor= ] }
737 { "RLCA" [ (emulate-RLCA) ] }
738 { "RRCA" [ (emulate-RRCA) ] }
740 { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] }
741 { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] }
742 { "POP-RR" [ [ pop-sp ] keep $2 ] }
743 { "PUSH-RR" [ [ $1 ] keep push-sp ] }
744 { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] }
745 { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] }
746 { "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] }
747 { "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] }
748 { "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] }
749 { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] }
750 { "JP-NN" [ [ pc>> ] keep [ read-word ] keep (>>pc) ] }
751 { "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ (>>pc) ] keep [ cycles>> ] keep swap 5 + swap (>>cycles) ] [ [ pc>> 2 + ] keep (>>pc) ] if ] }
752 { "JP-(RR)" [ [ $1 ] keep (>>pc) ] }
753 { "CALL-NN" [ (emulate-CALL) ] }
754 { "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ pc>> 2 + ] keep (>>pc) ] if ] }
755 { "LD-RR,NN" [ [ next-word ] keep $2 ] }
756 { "LD-RR,RR" [ [ $3 ] keep $2 ] }
757 { "LD-R,N" [ [ next-byte ] keep $2 ] }
758 { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] }
759 { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] }
760 { "LD-R,R" [ [ $3 ] keep $2 ] }
761 { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] }
762 { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] }
763 { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] }
764 { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] }
765 { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] }
766 { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] }
767 { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep (>>a) ] }
768 { "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] }
769 { "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
772 : 8-bit-registers ( -- parser )
773 #! A parser for 8-bit registers. On a successfull parse the
774 #! parse tree contains a vector. The first item in the vector
775 #! is the getter word for that register with stack effect
776 #! ( cpu -- value ). The second item is the setter word with
777 #! stack effect ( value cpu -- ).
779 main=("A" | "B" | "C" | "D" | "E" | "H" | "L") => [[ register-lookup ]]
782 : all-flags ( -- parser )
783 #! A parser for 16-bit flags.
785 main=("NZ" | "NC" | "PO" | "PE" | "Z" | "C" | "P" | "M") => [[ flag-lookup ]]
788 : 16-bit-registers ( -- parser )
789 #! A parser for 16-bit registers. On a successfull parse the
790 #! parse tree contains a vector. The first item in the vector
791 #! is the getter word for that register with stack effect
792 #! ( cpu -- value ). The second item is the setter word with
793 #! stack effect ( value cpu -- ).
795 main=("AF" | "BC" | "DE" | "HL" | "SP") => [[ register-lookup ]]
798 : all-registers ( -- parser )
799 #! Return a parser that can parse the format
800 #! for 8 bit or 16 bit registers.
801 [ 16-bit-registers , 8-bit-registers , ] choice* ;
803 : indirect ( parser -- parser )
804 #! Given a parser, return a parser which parses the original
805 #! wrapped in brackets, representing an indirect reference.
806 #! eg. BC -> (BC). The value of the original parser is left in
808 "(" ")" surrounded-by ;
810 : generate-instruction ( vector string -- quot )
811 #! Generate the quotation for an instruction, given the instruction in
812 #! the 'string' and a vector containing the arguments for that instruction.
813 patterns at replace-patterns ;
815 : simple-instruction ( token -- parser )
816 #! Return a parser for then instruction identified by the token.
817 #! The parser return parses the token only and expects no additional
818 #! arguments to the instruction.
819 token [ '[ { } _ generate-instruction ] ] action ;
821 : complex-instruction ( type token -- parser )
822 #! Return a parser for an instruction identified by the token.
823 #! The instruction is expected to take additional arguments by
824 #! being combined with other parsers. Then 'type' is used for a lookup
825 #! in a pattern hashtable to return the instruction quotation pattern.
826 token swap [ nip '[ _ generate-instruction ] ] curry action ;
828 : no-params ( ast -- ast )
829 first { } swap curry ;
831 : one-param ( ast -- ast )
834 : two-params ( ast -- ast )
835 first3 append swap curry ;
837 : NOP-instruction ( -- parser )
838 "NOP" simple-instruction ;
840 : RET-NN-instruction ( -- parser )
842 "RET-NN" "RET" complex-instruction ,
844 ] seq* [ no-params ] action ;
846 : RST-0-instruction ( -- parser )
848 "RST-0" "RST" complex-instruction ,
850 ] seq* [ no-params ] action ;
852 : RST-8-instruction ( -- parser )
854 "RST-8" "RST" complex-instruction ,
856 ] seq* [ no-params ] action ;
858 : RST-10H-instruction ( -- parser )
860 "RST-10H" "RST" complex-instruction ,
861 "10H" token sp hide ,
862 ] seq* [ no-params ] action ;
864 : RST-18H-instruction ( -- parser )
866 "RST-18H" "RST" complex-instruction ,
867 "18H" token sp hide ,
868 ] seq* [ no-params ] action ;
870 : RST-20H-instruction ( -- parser )
872 "RST-20H" "RST" complex-instruction ,
873 "20H" token sp hide ,
874 ] seq* [ no-params ] action ;
876 : RST-28H-instruction ( -- parser )
878 "RST-28H" "RST" complex-instruction ,
879 "28H" token sp hide ,
880 ] seq* [ no-params ] action ;
882 : RST-30H-instruction ( -- parser )
884 "RST-30H" "RST" complex-instruction ,
885 "30H" token sp hide ,
886 ] seq* [ no-params ] action ;
888 : RST-38H-instruction ( -- parser )
890 "RST-38H" "RST" complex-instruction ,
891 "38H" token sp hide ,
892 ] seq* [ no-params ] action ;
894 : JP-NN-instruction ( -- parser )
896 "JP-NN" "JP" complex-instruction ,
898 ] seq* [ no-params ] action ;
900 : JP-F|FF,NN-instruction ( -- parser )
902 "JP-F|FF,NN" "JP" complex-instruction ,
905 ] seq* [ one-param ] action ;
907 : JP-(RR)-instruction ( -- parser )
909 "JP-(RR)" "JP" complex-instruction ,
910 16-bit-registers indirect sp ,
911 ] seq* [ one-param ] action ;
913 : CALL-NN-instruction ( -- parser )
915 "CALL-NN" "CALL" complex-instruction ,
917 ] seq* [ no-params ] action ;
919 : CALL-F|FF,NN-instruction ( -- parser )
921 "CALL-F|FF,NN" "CALL" complex-instruction ,
924 ] seq* [ one-param ] action ;
926 : RLCA-instruction ( -- parser )
927 "RLCA" simple-instruction ;
929 : RRCA-instruction ( -- parser )
930 "RRCA" simple-instruction ;
932 : HALT-instruction ( -- parser )
933 "HALT" simple-instruction ;
935 : DI-instruction ( -- parser )
936 "DI" simple-instruction ;
938 : EI-instruction ( -- parser )
939 "EI" simple-instruction ;
941 : CPL-instruction ( -- parser )
942 "CPL" simple-instruction ;
944 : CCF-instruction ( -- parser )
945 "CCF" simple-instruction ;
947 : SCF-instruction ( -- parser )
948 "SCF" simple-instruction ;
950 : DAA-instruction ( -- parser )
951 "DAA" simple-instruction ;
953 : RLA-instruction ( -- parser )
954 "RLA" simple-instruction ;
956 : RRA-instruction ( -- parser )
957 "RRA" simple-instruction ;
959 : DEC-R-instruction ( -- parser )
961 "DEC-R" "DEC" complex-instruction ,
963 ] seq* [ one-param ] action ;
965 : DEC-RR-instruction ( -- parser )
967 "DEC-RR" "DEC" complex-instruction ,
968 16-bit-registers sp ,
969 ] seq* [ one-param ] action ;
971 : DEC-(RR)-instruction ( -- parser )
973 "DEC-(RR)" "DEC" complex-instruction ,
974 16-bit-registers indirect sp ,
975 ] seq* [ one-param ] action ;
977 : POP-RR-instruction ( -- parser )
979 "POP-RR" "POP" complex-instruction ,
981 ] seq* [ one-param ] action ;
983 : PUSH-RR-instruction ( -- parser )
985 "PUSH-RR" "PUSH" complex-instruction ,
987 ] seq* [ one-param ] action ;
989 : INC-R-instruction ( -- parser )
991 "INC-R" "INC" complex-instruction ,
993 ] seq* [ one-param ] action ;
995 : INC-RR-instruction ( -- parser )
997 "INC-RR" "INC" complex-instruction ,
998 16-bit-registers sp ,
999 ] seq* [ one-param ] action ;
1001 : INC-(RR)-instruction ( -- parser )
1003 "INC-(RR)" "INC" complex-instruction ,
1004 all-registers indirect sp ,
1005 ] seq* [ one-param ] action ;
1007 : RET-F|FF-instruction ( -- parser )
1009 "RET-F|FF" "RET" complex-instruction ,
1011 ] seq* [ one-param ] action ;
1013 : AND-N-instruction ( -- parser )
1015 "AND-N" "AND" complex-instruction ,
1017 ] seq* [ no-params ] action ;
1019 : AND-R-instruction ( -- parser )
1021 "AND-R" "AND" complex-instruction ,
1022 8-bit-registers sp ,
1023 ] seq* [ one-param ] action ;
1025 : AND-(RR)-instruction ( -- parser )
1027 "AND-(RR)" "AND" complex-instruction ,
1028 16-bit-registers indirect sp ,
1029 ] seq* [ one-param ] action ;
1031 : XOR-N-instruction ( -- parser )
1033 "XOR-N" "XOR" complex-instruction ,
1035 ] seq* [ no-params ] action ;
1037 : XOR-R-instruction ( -- parser )
1039 "XOR-R" "XOR" complex-instruction ,
1040 8-bit-registers sp ,
1041 ] seq* [ one-param ] action ;
1043 : XOR-(RR)-instruction ( -- parser )
1045 "XOR-(RR)" "XOR" complex-instruction ,
1046 16-bit-registers indirect sp ,
1047 ] seq* [ one-param ] action ;
1049 : OR-N-instruction ( -- parser )
1051 "OR-N" "OR" complex-instruction ,
1053 ] seq* [ no-params ] action ;
1055 : OR-R-instruction ( -- parser )
1057 "OR-R" "OR" complex-instruction ,
1058 8-bit-registers sp ,
1059 ] seq* [ one-param ] action ;
1061 : OR-(RR)-instruction ( -- parser )
1063 "OR-(RR)" "OR" complex-instruction ,
1064 16-bit-registers indirect sp ,
1065 ] seq* [ one-param ] action ;
1067 : CP-N-instruction ( -- parser )
1069 "CP-N" "CP" complex-instruction ,
1071 ] seq* [ no-params ] action ;
1073 : CP-R-instruction ( -- parser )
1075 "CP-R" "CP" complex-instruction ,
1076 8-bit-registers sp ,
1077 ] seq* [ one-param ] action ;
1079 : CP-(RR)-instruction ( -- parser )
1081 "CP-(RR)" "CP" complex-instruction ,
1082 16-bit-registers indirect sp ,
1083 ] seq* [ one-param ] action ;
1085 : ADC-R,N-instruction ( -- parser )
1087 "ADC-R,N" "ADC" complex-instruction ,
1088 8-bit-registers sp ,
1090 ] seq* [ one-param ] action ;
1092 : ADC-R,R-instruction ( -- parser )
1094 "ADC-R,R" "ADC" complex-instruction ,
1095 8-bit-registers sp ,
1098 ] seq* [ two-params ] action ;
1100 : ADC-R,(RR)-instruction ( -- parser )
1102 "ADC-R,(RR)" "ADC" complex-instruction ,
1103 8-bit-registers sp ,
1105 16-bit-registers indirect ,
1106 ] seq* [ two-params ] action ;
1108 : SBC-R,N-instruction ( -- parser )
1110 "SBC-R,N" "SBC" complex-instruction ,
1111 8-bit-registers sp ,
1113 ] seq* [ one-param ] action ;
1115 : SBC-R,R-instruction ( -- parser )
1117 "SBC-R,R" "SBC" complex-instruction ,
1118 8-bit-registers sp ,
1121 ] seq* [ two-params ] action ;
1123 : SBC-R,(RR)-instruction ( -- parser )
1125 "SBC-R,(RR)" "SBC" complex-instruction ,
1126 8-bit-registers sp ,
1128 16-bit-registers indirect ,
1129 ] seq* [ two-params ] action ;
1131 : SUB-R-instruction ( -- parser )
1133 "SUB-R" "SUB" complex-instruction ,
1134 8-bit-registers sp ,
1135 ] seq* [ one-param ] action ;
1137 : SUB-(RR)-instruction ( -- parser )
1139 "SUB-(RR)" "SUB" complex-instruction ,
1140 16-bit-registers indirect sp ,
1141 ] seq* [ one-param ] action ;
1143 : SUB-N-instruction ( -- parser )
1145 "SUB-N" "SUB" complex-instruction ,
1147 ] seq* [ no-params ] action ;
1149 : ADD-R,N-instruction ( -- parser )
1151 "ADD-R,N" "ADD" complex-instruction ,
1152 8-bit-registers sp ,
1154 ] seq* [ one-param ] action ;
1156 : ADD-R,R-instruction ( -- parser )
1158 "ADD-R,R" "ADD" complex-instruction ,
1159 8-bit-registers sp ,
1162 ] seq* [ two-params ] action ;
1164 : ADD-RR,RR-instruction ( -- parser )
1166 "ADD-RR,RR" "ADD" complex-instruction ,
1167 16-bit-registers sp ,
1170 ] seq* [ two-params ] action ;
1172 : ADD-R,(RR)-instruction ( -- parser )
1174 "ADD-R,(RR)" "ADD" complex-instruction ,
1175 8-bit-registers sp ,
1177 16-bit-registers indirect ,
1178 ] seq* [ two-params ] action ;
1180 : LD-RR,NN-instruction ( -- parser )
1183 "LD-RR,NN" "LD" complex-instruction ,
1184 16-bit-registers sp ,
1186 ] seq* [ one-param ] action ;
1188 : LD-R,N-instruction ( -- parser )
1191 "LD-R,N" "LD" complex-instruction ,
1192 8-bit-registers sp ,
1194 ] seq* [ one-param ] action ;
1196 : LD-(RR),N-instruction ( -- parser )
1198 "LD-(RR),N" "LD" complex-instruction ,
1199 16-bit-registers indirect sp ,
1201 ] seq* [ one-param ] action ;
1203 : LD-(RR),R-instruction ( -- parser )
1206 "LD-(RR),R" "LD" complex-instruction ,
1207 16-bit-registers indirect sp ,
1210 ] seq* [ two-params ] action ;
1212 : LD-R,R-instruction ( -- parser )
1214 "LD-R,R" "LD" complex-instruction ,
1215 8-bit-registers sp ,
1218 ] seq* [ two-params ] action ;
1220 : LD-RR,RR-instruction ( -- parser )
1222 "LD-RR,RR" "LD" complex-instruction ,
1223 16-bit-registers sp ,
1226 ] seq* [ two-params ] action ;
1228 : LD-R,(RR)-instruction ( -- parser )
1230 "LD-R,(RR)" "LD" complex-instruction ,
1231 8-bit-registers sp ,
1233 16-bit-registers indirect ,
1234 ] seq* [ two-params ] action ;
1236 : LD-(NN),RR-instruction ( -- parser )
1238 "LD-(NN),RR" "LD" complex-instruction ,
1239 "nn" token indirect sp hide ,
1242 ] seq* [ one-param ] action ;
1244 : LD-(NN),R-instruction ( -- parser )
1246 "LD-(NN),R" "LD" complex-instruction ,
1247 "nn" token indirect sp hide ,
1250 ] seq* [ one-param ] action ;
1252 : LD-RR,(NN)-instruction ( -- parser )
1254 "LD-RR,(NN)" "LD" complex-instruction ,
1255 16-bit-registers sp ,
1257 "nn" token indirect hide ,
1258 ] seq* [ one-param ] action ;
1260 : LD-R,(NN)-instruction ( -- parser )
1262 "LD-R,(NN)" "LD" complex-instruction ,
1263 8-bit-registers sp ,
1265 "nn" token indirect hide ,
1266 ] seq* [ one-param ] action ;
1268 : OUT-(N),R-instruction ( -- parser )
1270 "OUT-(N),R" "OUT" complex-instruction ,
1271 "n" token indirect sp hide ,
1274 ] seq* [ one-param ] action ;
1276 : IN-R,(N)-instruction ( -- parser )
1278 "IN-R,(N)" "IN" complex-instruction ,
1279 8-bit-registers sp ,
1281 "n" token indirect hide ,
1282 ] seq* [ one-param ] action ;
1284 : EX-(RR),RR-instruction ( -- parser )
1286 "EX-(RR),RR" "EX" complex-instruction ,
1287 16-bit-registers indirect sp ,
1290 ] seq* [ two-params ] action ;
1292 : EX-RR,RR-instruction ( -- parser )
1294 "EX-RR,RR" "EX" complex-instruction ,
1295 16-bit-registers sp ,
1298 ] seq* [ two-params ] action ;
1300 : 8080-generator-parser ( -- parser )
1305 RST-10H-instruction ,
1306 RST-18H-instruction ,
1307 RST-20H-instruction ,
1308 RST-28H-instruction ,
1309 RST-30H-instruction ,
1310 RST-38H-instruction ,
1311 JP-F|FF,NN-instruction ,
1313 JP-(RR)-instruction ,
1314 CALL-F|FF,NN-instruction ,
1315 CALL-NN-instruction ,
1329 AND-(RR)-instruction ,
1332 XOR-(RR)-instruction ,
1335 OR-(RR)-instruction ,
1338 CP-(RR)-instruction ,
1339 DEC-RR-instruction ,
1341 DEC-(RR)-instruction ,
1342 POP-RR-instruction ,
1343 PUSH-RR-instruction ,
1344 INC-RR-instruction ,
1346 INC-(RR)-instruction ,
1347 LD-RR,NN-instruction ,
1348 LD-RR,RR-instruction ,
1349 LD-R,N-instruction ,
1350 LD-R,R-instruction ,
1351 LD-(RR),N-instruction ,
1352 LD-(RR),R-instruction ,
1353 LD-R,(RR)-instruction ,
1354 LD-(NN),RR-instruction ,
1355 LD-(NN),R-instruction ,
1356 LD-RR,(NN)-instruction ,
1357 LD-R,(NN)-instruction ,
1358 ADC-R,(RR)-instruction ,
1359 ADC-R,N-instruction ,
1360 ADC-R,R-instruction ,
1361 ADD-R,N-instruction ,
1362 ADD-R,(RR)-instruction ,
1363 ADD-R,R-instruction ,
1364 ADD-RR,RR-instruction ,
1365 SBC-R,N-instruction ,
1366 SBC-R,R-instruction ,
1367 SBC-R,(RR)-instruction ,
1369 SUB-(RR)-instruction ,
1371 RET-F|FF-instruction ,
1372 RET-NN-instruction ,
1373 OUT-(N),R-instruction ,
1374 IN-R,(N)-instruction ,
1375 EX-(RR),RR-instruction ,
1376 EX-RR,RR-instruction ,
1377 ] choice* [ call( -- quot ) ] action ;
1379 : instruction-quotations ( string -- emulate-quot )
1380 #! Given an instruction string, return the emulation quotation for
1381 #! it. This will later be expanded to produce the disassembly and
1382 #! assembly quotations.
1383 8080-generator-parser parse ;
1385 SYMBOL: last-instruction
1388 : parse-instructions ( list -- )
1389 #! Process the list of strings, which should make
1390 #! up an 8080 instruction, and output a quotation
1391 #! that would implement that instruction.
1392 dup " " join instruction-quotations
1394 "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
1395 ] dip (( cpu -- )) define-declared ;
1397 SYNTAX: INSTRUCTION: ";" parse-tokens parse-instructions ;
1400 #! Set the number of cycles for the last instruction that was defined.
1401 scan string>number last-opcode global at instruction-cycles set-nth ;
1403 SYNTAX: opcode ( -- )
1404 #! Set the opcode number for the last instruction that was defined.
1405 last-instruction global at 1quotation scan 16 base>
1406 dup last-opcode global set-at set-instruction ;