1 ! Copyright (C) 2006 Chris Double.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors kernel math sequences words arrays io io.files
5 namespaces math.parser assocs quotations parser lexer
6 parser-combinators tools.time io.encodings.binary sequences.deep
10 TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
12 GENERIC: reset ( cpu -- )
13 GENERIC: update-video ( value addr cpu -- )
14 GENERIC: read-port ( port cpu -- byte )
15 GENERIC: write-port ( value port cpu -- )
17 M: cpu update-video ( value addr cpu -- )
20 M: cpu read-port ( port cpu -- byte )
21 #! Read a byte from the hardware port. 'port' should
25 M: cpu write-port ( value port cpu -- )
26 #! Write a byte to the hardware port, where 'port' is
30 : carry-flag HEX: 01 ; inline
31 : parity-flag HEX: 04 ; inline
32 : half-carry-flag HEX: 10 ; inline
33 : interrupt-flag HEX: 20 ; inline
34 : zero-flag HEX: 40 ; inline
35 : sign-flag HEX: 80 ; inline
37 : >word< ( word -- byte byte )
38 #! Explode a word into its two 8 bit values.
39 dup HEX: FF bitand swap -8 shift HEX: FF bitand swap ;
41 : cpu-af ( cpu -- word )
42 #! Return the 16-bit pseudo register AF.
43 [ cpu-a 8 shift ] keep cpu-f bitor ;
45 : set-cpu-af ( value cpu -- )
46 #! Set the value of the 16-bit pseudo register AF
47 >r >word< r> tuck set-cpu-f set-cpu-a ;
49 : cpu-bc ( cpu -- word )
50 #! Return the 16-bit pseudo register BC.
51 [ cpu-b 8 shift ] keep cpu-c bitor ;
53 : set-cpu-bc ( value cpu -- )
54 #! Set the value of the 16-bit pseudo register BC
55 >r >word< r> tuck set-cpu-c set-cpu-b ;
57 : cpu-de ( cpu -- word )
58 #! Return the 16-bit pseudo register DE.
59 [ cpu-d 8 shift ] keep cpu-e bitor ;
61 : set-cpu-de ( value cpu -- )
62 #! Set the value of the 16-bit pseudo register DE
63 >r >word< r> tuck set-cpu-e set-cpu-d ;
65 : cpu-hl ( cpu -- word )
66 #! Return the 16-bit pseudo register HL.
67 [ cpu-h 8 shift ] keep cpu-l bitor ;
69 : set-cpu-hl ( value cpu -- )
70 #! Set the value of the 16-bit pseudo register HL
71 >r >word< r> tuck set-cpu-l set-cpu-h ;
73 : flag-set? ( flag cpu -- bool )
74 cpu-f bitand 0 = not ;
76 : flag-clear? ( flag cpu -- bool )
79 : flag-nz? ( cpu -- bool )
81 cpu-f zero-flag bitand 0 = ;
83 : flag-z? ( cpu -- bool )
85 cpu-f zero-flag bitand 0 = not ;
87 : flag-nc? ( cpu -- bool )
89 cpu-f carry-flag bitand 0 = ;
91 : flag-c? ( cpu -- bool )
93 cpu-f carry-flag bitand 0 = not ;
95 : flag-po? ( cpu -- bool )
97 cpu-f parity-flag bitand 0 = ;
99 : flag-pe? ( cpu -- bool )
101 cpu-f parity-flag bitand 0 = not ;
103 : flag-p? ( cpu -- bool )
105 cpu-f sign-flag bitand 0 = ;
107 : flag-m? ( cpu -- bool )
109 cpu-f sign-flag bitand 0 = not ;
111 : read-byte ( addr cpu -- byte )
112 #! Read one byte from memory at the specified address.
113 #! The address is 16-bit, but if a value greater than
114 #! 0xFFFF is provided then return a default value.
121 : read-word ( addr cpu -- word )
122 #! Read a 16-bit word from memory at the specified address.
123 #! The address is 16-bit, but if a value greater than
124 #! 0xFFFF is provided then return a default value.
125 [ read-byte ] 2keep >r 1 + r> read-byte 8 shift bitor ;
127 : next-byte ( cpu -- byte )
128 #! Return the value of the byte at PC, and increment PC.
134 : next-word ( cpu -- word )
135 #! Return the value of the word at PC, and increment PC.
142 : write-byte ( value addr cpu -- )
143 #! Write a byte to the specified memory address.
144 over dup HEX: 2000 < swap HEX: FFFF > or [
152 : write-word ( value addr cpu -- )
153 #! Write a 16-bit word to the specified memory address.
154 >r >r >word< r> r> [ write-byte ] 2keep >r 1 + r> write-byte ;
156 : cpu-a-bitand ( quot cpu -- )
158 [ cpu-a swap call bitand ] keep set-cpu-a ; inline
160 : cpu-a-bitor ( quot cpu -- )
162 [ cpu-a swap call bitor ] keep set-cpu-a ; inline
164 : cpu-a-bitxor ( quot cpu -- )
166 [ cpu-a swap call bitxor ] keep set-cpu-a ; inline
168 : cpu-a-bitxor= ( value cpu -- )
170 [ cpu-a bitxor ] keep set-cpu-a ;
172 : cpu-f-bitand ( quot cpu -- )
174 [ cpu-f swap call bitand ] keep set-cpu-f ; inline
176 : cpu-f-bitor ( quot cpu -- )
178 [ cpu-f swap call bitor ] keep set-cpu-f ; inline
180 : cpu-f-bitxor ( quot cpu -- )
182 [ cpu-f swap call bitxor ] keep set-cpu-f ; inline
184 : cpu-f-bitor= ( value cpu -- )
186 [ cpu-f bitor ] keep set-cpu-f ;
188 : cpu-f-bitand= ( value cpu -- )
190 [ cpu-f bitand ] keep set-cpu-f ;
192 : cpu-f-bitxor= ( value cpu -- )
194 [ cpu-f bitxor ] keep set-cpu-f ;
196 : set-flag ( cpu flag -- )
199 : clear-flag ( cpu flag -- )
200 bitnot HEX: FF bitand swap cpu-f-bitand= ;
202 : update-zero-flag ( result cpu -- )
203 #! If the result of an instruction has the value 0, this
204 #! flag is set, otherwise it is reset.
205 swap HEX: FF bitand 0 = [ zero-flag set-flag ] [ zero-flag clear-flag ] if ;
207 : update-sign-flag ( result cpu -- )
208 #! If the most significant bit of the result
209 #! has the value 1 then the flag is set, otherwise
211 swap HEX: 80 bitand 0 = [ sign-flag clear-flag ] [ sign-flag set-flag ] if ;
213 : update-parity-flag ( result cpu -- )
214 #! If the modulo 2 sum of the bits of the result
215 #! is 0, (ie. if the result has even parity) this flag
216 #! is set, otherwise it is reset.
217 swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] if ;
219 : update-carry-flag ( result cpu -- )
220 #! If the instruction resulted in a carry (from addition)
221 #! or a borrow (from subtraction or a comparison) out of the
222 #! higher order bit, this flag is set, otherwise it is reset.
223 swap dup HEX: 100 >= swap 0 < or [ carry-flag set-flag ] [ carry-flag clear-flag ] if ;
225 : update-half-carry-flag ( original change-by result cpu -- )
226 #! If the instruction caused a carry out of bit 3 and into bit 4 of the
227 #! resulting value, the half carry flag is set, otherwise it is reset.
228 #! The 'original' is the original value of the register being changed.
229 #! 'change-by' is the amount it is being added or decremented by.
230 #! 'result' is the result of that change.
231 >r bitxor bitxor HEX: 10 bitand 0 = not r>
232 swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ;
234 : update-flags ( result cpu -- )
235 2dup update-carry-flag
236 2dup update-parity-flag
237 2dup update-sign-flag
240 : update-flags-no-carry ( result cpu -- )
241 2dup update-parity-flag
242 2dup update-sign-flag
245 : add-byte ( lhs rhs cpu -- result )
247 >r 2dup + r> ! lhs rhs result cpu
248 [ update-flags ] 2keep
249 [ update-half-carry-flag ] 2keep
250 drop HEX: FF bitand ;
252 : add-carry ( change-by result cpu -- change-by result )
253 #! Add the effect of the carry flag to the result
254 flag-c? [ 1 + >r 1 + r> ] when ;
256 : add-byte-with-carry ( lhs rhs cpu -- result )
257 #! Add rhs to lhs plus carry.
258 >r 2dup + r> ! lhs rhs result cpu
260 [ update-flags ] 2keep
261 [ update-half-carry-flag ] 2keep
262 drop HEX: FF bitand ;
264 : sub-carry ( change-by result cpu -- change-by result )
265 #! Subtract the effect of the carry flag from the result
266 flag-c? [ 1 - >r 1 - r> ] when ;
268 : sub-byte ( lhs rhs cpu -- result )
269 #! Subtract rhs from lhs
271 [ update-flags ] 2keep
272 [ update-half-carry-flag ] 2keep
273 drop HEX: FF bitand ;
275 : sub-byte-with-carry ( lhs rhs cpu -- result )
276 #! Subtract rhs from lhs and take carry into account
279 [ update-flags ] 2keep
280 [ update-half-carry-flag ] 2keep
281 drop HEX: FF bitand ;
283 : inc-byte ( byte cpu -- result )
284 #! Increment byte by one. Note that carry flag is not affected
285 #! by this operation.
286 >r 1 2dup + r> ! lhs rhs result cpu
287 [ update-flags-no-carry ] 2keep
288 [ update-half-carry-flag ] 2keep
289 drop HEX: FF bitand ;
291 : dec-byte ( byte cpu -- result )
292 #! Decrement byte by one. Note that carry flag is not affected
293 #! by this operation.
294 >r 1 2dup - r> ! lhs rhs result cpu
295 [ update-flags-no-carry ] 2keep
296 [ update-half-carry-flag ] 2keep
297 drop HEX: FF bitand ;
299 : inc-word ( w cpu -- w )
300 #! Increment word by one. Note that no flags are modified.
301 drop 1 + HEX: FFFF bitand ;
303 : dec-word ( w cpu -- w )
304 #! Decrement word by one. Note that no flags are modified.
305 drop 1 - HEX: FFFF bitand ;
307 : add-word ( lhs rhs cpu -- result )
308 #! Add rhs to lhs. Note that only the carry flag is modified
309 #! and only if there is a carry out of the double precision add.
310 >r + r> over HEX: FFFF > [ carry-flag set-flag ] [ drop ] if HEX: FFFF bitand ;
312 : bit3or ( lhs rhs -- 0|1 )
313 #! bitor bit 3 of the two numbers on the stack
314 BIN: 00001000 bitand -3 shift >r
315 BIN: 00001000 bitand -3 shift r>
318 : and-byte ( lhs rhs cpu -- result )
319 #! Logically and rhs to lhs. The carry flag is cleared and
320 #! the half carry is set to the ORing of bits 3 of the operands.
321 [ drop bit3or ] 3keep ! bit3or lhs rhs cpu
322 >r bitand r> [ update-flags ] 2keep
323 [ carry-flag clear-flag ] keep
324 rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if
327 : xor-byte ( lhs rhs cpu -- result )
328 #! Logically xor rhs to lhs. The carry and half-carry flags are cleared.
329 >r bitxor r> [ update-flags ] 2keep
330 [ half-carry-flag carry-flag bitor clear-flag ] keep
331 drop HEX: FF bitand ;
333 : or-byte ( lhs rhs cpu -- result )
334 #! Logically or rhs to lhs. The carry and half-carry flags are cleared.
335 >r bitor r> [ update-flags ] 2keep
336 [ half-carry-flag carry-flag bitor clear-flag ] keep
337 drop HEX: FF bitand ;
339 : flags ( seq -- seq )
340 [ 0 [ execute bitor ] reduce ] map ;
342 : decrement-sp ( n cpu -- )
343 #! Decrement the stackpointer by n.
345 >r swap - r> set-cpu-sp ;
348 #! Save the value of the PC on the stack.
349 [ cpu-pc ] keep ! pc cpu
350 [ cpu-sp ] keep ! pc sp cpu
354 #! Push the value of the PC on the stack.
358 : pop-pc ( cpu -- pc )
359 #! Pop the value of the PC off the stack.
362 -2 swap decrement-sp ;
364 : push-sp ( value cpu -- )
365 [ 2 swap decrement-sp ] keep
369 : pop-sp ( cpu -- value )
372 -2 swap decrement-sp ;
374 : call-sub ( addr cpu -- )
375 #! Call the address as a subroutine.
377 >r HEX: FFFF bitand r> set-cpu-pc ;
379 : ret-from-sub ( cpu -- )
380 [ pop-pc ] keep set-cpu-pc ;
382 : interrupt ( number cpu -- )
383 #! Perform a hardware interrupt
384 ! "***Interrupt: " write over 16 >base print
385 dup cpu-f interrupt-flag bitand 0 = not [
392 : inc-cycles ( n cpu -- )
393 #! Increment the number of cpu cycles
394 [ cpu-cycles + ] keep set-cpu-cycles ;
396 : instruction-cycles ( -- vector )
397 #! Return a 256 element vector containing the cycles for
398 #! each opcode in the 8080 instruction set.
399 << 256 f <array> parsed >> ;
401 : not-implemented ( <cpu> -- )
404 : instructions ( -- vector )
405 #! Return a 256 element vector containing the emulation words for
406 #! each opcode in the 8080 instruction set.
407 << 256 [ [ not-implemented ] 2array ] map parsed >> ; inline
409 : set-instruction ( quot n -- )
410 tuck >r 2array r> instructions set-nth ;
412 M: cpu reset ( cpu -- )
413 #! Reset the CPU to its poweron state
414 [ 0 swap set-cpu-b ] keep
415 [ 0 swap set-cpu-c ] keep
416 [ 0 swap set-cpu-d ] keep
417 [ 0 swap set-cpu-e ] keep
418 [ 0 swap set-cpu-h ] keep
419 [ 0 swap set-cpu-l ] keep
420 [ 0 swap set-cpu-a ] keep
421 [ 0 swap set-cpu-f ] keep
422 [ 0 swap set-cpu-pc ] keep
423 [ HEX: F000 swap set-cpu-sp ] keep
424 [ HEX: FFFF 0 <array> swap set-cpu-ram ] keep
425 [ f swap set-cpu-halted? ] keep
426 [ HEX: 10 swap set-cpu-last-interrupt ] keep
427 0 swap set-cpu-cycles ;
429 : <cpu> ( -- cpu ) cpu new dup reset ;
431 : (load-rom) ( n ram -- )
433 -rot [ set-nth ] 2keep >r 1 + r> (load-rom)
438 #! Reads the ROM from stdin and stores it in ROM from
440 : load-rom ( filename cpu -- )
441 #! Load the contents of the file into ROM.
442 #! (address 0x0000-0x1FFF).
443 cpu-ram swap binary [
449 : rom-dir ( -- string )
450 rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ;
452 : load-rom* ( seq cpu -- )
453 #! 'seq' is an array of arrays. Each array contains
454 #! an address and filename of a ROM file. The ROM
455 #! file will be loaded at the specified address. This
456 #! file path shoul dbe relative to the '/roms' resource path.
459 swap first2 rom-dir prepend-path binary [
466 "Set 'rom-root' to the path containing the root of the 8080 ROM files." throw
469 : read-instruction ( cpu -- word )
470 #! Read the next instruction from the cpu's program
471 #! counter, and increment the program counter.
472 [ cpu-pc ] keep ! pc cpu
473 [ over 1 + swap set-cpu-pc ] keep
476 : get-cycles ( n -- opcode )
477 #! Returns the cycles for the given instruction value.
478 #! If the opcode is not defined throw an error.
479 dup instruction-cycles nth [
482 [ "Undefined 8080 opcode: " % number>string % ] "" make throw
485 : process-interrupts ( cpu -- )
486 #! Process any hardware interrupts
491 [ >r 16667 - r> set-cpu-cycles ] keep
492 dup cpu-last-interrupt HEX: 10 = [
493 HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt
495 HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt
499 : peek-instruction ( cpu -- word )
500 #! Return the next instruction from the cpu's program
501 #! counter, but don't increment the counter.
502 [ cpu-pc ] keep read-byte instructions nth first ;
505 [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
506 [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
507 [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
508 [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
509 [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
510 [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
511 [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
512 [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
513 [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
514 [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
515 [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
516 [ " " write peek-instruction name>> write " " write ] keep
520 [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
521 [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
522 [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
523 [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
524 [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
525 [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
526 [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
527 [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
528 [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
529 [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
530 [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
533 : register-lookup ( string -- vector )
534 #! Given a string containing a register name, return a vector
535 #! where the 1st item is the getter and the 2nd is the setter
536 #! for that register.
538 { "A" { cpu-a set-cpu-a } }
539 { "B" { cpu-b set-cpu-b } }
540 { "C" { cpu-c set-cpu-c } }
541 { "D" { cpu-d set-cpu-d } }
542 { "E" { cpu-e set-cpu-e } }
543 { "H" { cpu-h set-cpu-h } }
544 { "L" { cpu-l set-cpu-l } }
545 { "AF" { cpu-af set-cpu-af } }
546 { "BC" { cpu-bc set-cpu-bc } }
547 { "DE" { cpu-de set-cpu-de } }
548 { "HL" { cpu-hl set-cpu-hl } }
549 { "SP" { cpu-sp set-cpu-sp } }
553 : flag-lookup ( string -- vector )
554 #! Given a string containing a flag name, return a vector
555 #! where the 1st item is a word that tests that flag.
557 { "NZ" { flag-nz? } }
558 { "NC" { flag-nc? } }
559 { "PO" { flag-po? } }
560 { "PE" { flag-pe? } }
567 SYMBOLS: $1 $2 $3 $4 ;
569 : replace-patterns ( vector tree -- tree )
580 : (emulate-RST) ( n cpu -- )
582 [ cpu-sp 2 - dup ] keep ! sp sp cpu
583 [ set-cpu-sp ] keep ! sp cpu
584 [ cpu-pc ] keep ! sp pc cpu
585 swapd [ write-word ] keep ! cpu
586 >r 8 * r> set-cpu-pc ;
588 : (emulate-CALL) ( cpu -- )
590 [ next-word HEX: FFFF bitand ] keep ! addr cpu
591 [ cpu-sp 2 - dup ] keep ! addr sp sp cpu
592 [ set-cpu-sp ] keep ! addr sp cpu
593 [ cpu-pc ] keep ! addr sp pc cpu
594 swapd [ write-word ] keep ! addr cpu
597 : (emulate-RLCA) ( cpu -- )
598 #! The content of the accumulator is rotated left
599 #! one position. The low order bit and the carry flag
600 #! are both set to the value shifd out of the high
601 #! order bit position. Only the carry flag is affected.
602 [ cpu-a -7 shift ] keep
603 over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
604 [ cpu-a 1 shift HEX: FF bitand ] keep
605 >r bitor r> set-cpu-a ;
607 : (emulate-RRCA) ( cpu -- )
608 #! The content of the accumulator is rotated right
609 #! one position. The high order bit and the carry flag
610 #! are both set to the value shifd out of the low
611 #! order bit position. Only the carry flag is affected.
612 [ cpu-a 1 bitand 7 shift ] keep
613 over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
614 [ cpu-a 254 bitand -1 shift ] keep
615 >r bitor r> set-cpu-a ;
617 : (emulate-RLA) ( cpu -- )
618 #! The content of the accumulator is rotated left
619 #! one position through the carry flag. The low
620 #! order bit is set equal to the carry flag and
621 #! the carry flag is set to the value shifd out
622 #! of the high order bit. Only the carry flag is
624 [ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
625 [ cpu-a 127 bitand 7 shift ] keep
626 dup cpu-a 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
627 >r bitor r> set-cpu-a ;
629 : (emulate-RRA) ( cpu -- )
630 #! The content of the accumulator is rotated right
631 #! one position through the carry flag. The high order
632 #! bit is set to the carry flag and the carry flag is
633 #! set to the value shifd out of the low order bit.
634 #! Only the carry flag is affected.
635 [ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep
636 [ cpu-a 254 bitand -1 shift ] keep
637 dup cpu-a 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
638 >r bitor r> set-cpu-a ;
640 : (emulate-CPL) ( cpu -- )
641 #! The contents of the accumulator are complemented
642 #! (zero bits become one, one bits becomes zero).
643 #! No flags are affected.
644 HEX: FF swap cpu-a-bitxor= ;
646 : (emulate-DAA) ( cpu -- )
647 #! The eight bit number in the accumulator is
648 #! adjusted to form two four-bit binary-coded-decimal
651 dup half-carry-flag swap flag-set? swap
652 cpu-a BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] if
655 [ update-flags ] 2keep
656 [ swap HEX: FF bitand swap set-cpu-a ] keep
658 dup carry-flag swap flag-set? swap
659 cpu-a -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if
662 [ update-flags ] 2keep
663 swap HEX: FF bitand swap set-cpu-a ;
665 : patterns ( -- hashtable )
666 #! table of code quotation patterns for each type of instruction.
669 { "RET-NN" [ ret-from-sub ] }
670 { "RST-0" [ 0 swap (emulate-RST) ] }
671 { "RST-8" [ 8 swap (emulate-RST) ] }
672 { "RST-10H" [ HEX: 10 swap (emulate-RST) ] }
673 { "RST-18H" [ HEX: 18 swap (emulate-RST) ] }
674 { "RST-20H" [ HEX: 20 swap (emulate-RST) ] }
675 { "RST-28H" [ HEX: 28 swap (emulate-RST) ] }
676 { "RST-30H" [ HEX: 30 swap (emulate-RST) ] }
677 { "RST-38H" [ HEX: 38 swap (emulate-RST) ] }
678 { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
679 { "CP-N" [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] }
680 { "CP-R" [ [ cpu-a ] keep [ $1 ] keep sub-byte drop ] }
681 { "CP-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] }
682 { "OR-N" [ [ cpu-a ] keep [ next-byte ] keep [ or-byte ] keep set-cpu-a ] }
683 { "OR-R" [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] }
684 { "OR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a ] }
685 { "XOR-N" [ [ cpu-a ] keep [ next-byte ] keep [ xor-byte ] keep set-cpu-a ] }
686 { "XOR-R" [ [ cpu-a ] keep [ $1 ] keep [ xor-byte ] keep set-cpu-a ] }
687 { "XOR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep set-cpu-a ] }
688 { "AND-N" [ [ cpu-a ] keep [ next-byte ] keep [ and-byte ] keep set-cpu-a ] }
689 { "AND-R" [ [ cpu-a ] keep [ $1 ] keep [ and-byte ] keep set-cpu-a ] }
690 { "AND-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep set-cpu-a ] }
691 { "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] }
692 { "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] }
693 { "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] }
694 { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] }
695 { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] }
696 { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] }
697 { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] }
698 { "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
699 { "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] }
700 { "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
701 { "SUB-R" [ [ cpu-a ] keep [ $1 ] keep [ sub-byte ] keep set-cpu-a ] }
702 { "SUB-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep set-cpu-a ] }
703 { "SUB-N" [ [ cpu-a ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] }
704 { "CPL" [ (emulate-CPL) ] }
705 { "DAA" [ (emulate-DAA) ] }
706 { "RLA" [ (emulate-RLA) ] }
707 { "RRA" [ (emulate-RRA) ] }
708 { "CCF" [ carry-flag swap cpu-f-bitxor= ] }
709 { "SCF" [ carry-flag swap cpu-f-bitor= ] }
710 { "RLCA" [ (emulate-RLCA) ] }
711 { "RRCA" [ (emulate-RRCA) ] }
713 { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] }
714 { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] }
715 { "POP-RR" [ [ pop-sp ] keep $2 ] }
716 { "PUSH-RR" [ [ $1 ] keep push-sp ] }
717 { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] }
718 { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] }
719 { "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] }
720 { "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] }
721 { "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] }
722 { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] }
723 { "JP-NN" [ [ cpu-pc ] keep [ read-word ] keep set-cpu-pc ] }
724 { "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 ] }
725 { "JP-(RR)" [ [ $1 ] keep set-cpu-pc ] }
726 { "CALL-NN" [ (emulate-CALL) ] }
727 { "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] }
728 { "LD-RR,NN" [ [ next-word ] keep $2 ] }
729 { "LD-RR,RR" [ [ $3 ] keep $2 ] }
730 { "LD-R,N" [ [ next-byte ] keep $2 ] }
731 { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] }
732 { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] }
733 { "LD-R,R" [ [ $3 ] keep $2 ] }
734 { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] }
735 { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] }
736 { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] }
737 { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] }
738 { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] }
739 { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] }
740 { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] }
741 { "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] }
742 { "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
745 : 8-bit-registers ( -- parser )
746 #! A parser for 8-bit registers. On a successfull parse the
747 #! parse tree contains a vector. The first item in the vector
748 #! is the getter word for that register with stack effect
749 #! ( cpu -- value ). The second item is the setter word with
750 #! stack effect ( value cpu -- ).
757 "L" token <|> [ register-lookup ] <@ ;
759 : all-flags ( -- parser )
760 #! A parser for 16-bit flags.
768 "M" token <|> [ flag-lookup ] <@ ;
770 : 16-bit-registers ( -- parser )
771 #! A parser for 16-bit registers. On a successfull parse the
772 #! parse tree contains a vector. The first item in the vector
773 #! is the getter word for that register with stack effect
774 #! ( cpu -- value ). The second item is the setter word with
775 #! stack effect ( value cpu -- ).
780 "SP" token <|> [ register-lookup ] <@ ;
782 : all-registers ( -- parser )
783 #! Return a parser that can parse the format
784 #! for 8 bit or 16 bit registers.
785 8-bit-registers 16-bit-registers <|> ;
787 : indirect ( parser -- parser )
788 #! Given a parser, return a parser which parses the original
789 #! wrapped in brackets, representing an indirect reference.
790 #! eg. BC -> (BC). The value of the original parser is left in
792 "(" token swap &> ")" token <& ;
794 : generate-instruction ( vector string -- quot )
795 #! Generate the quotation for an instruction, given the instruction in
796 #! the 'string' and a vector containing the arguments for that instruction.
797 patterns at replace-patterns ;
799 : simple-instruction ( token -- parser )
800 #! Return a parser for then instruction identified by the token.
801 #! The parser return parses the token only and expects no additional
802 #! arguments to the instruction.
803 token [ [ { } clone , , \ generate-instruction , ] [ ] make ] <@ ;
805 : complex-instruction ( type token -- parser )
806 #! Return a parser for an instruction identified by the token.
807 #! The instruction is expected to take additional arguments by
808 #! being combined with other parsers. Then 'type' is used for a lookup
809 #! in a pattern hashtable to return the instruction quotation pattern.
810 token swap [ nip [ , \ generate-instruction , ] [ ] make ] curry <@ ;
812 : NOP-instruction ( -- parser )
813 "NOP" simple-instruction ;
815 : RET-NN-instruction ( -- parser )
816 "RET-NN" "RET" complex-instruction
818 just [ { } clone swap curry ] <@ ;
820 : RST-0-instruction ( -- parser )
821 "RST-0" "RST" complex-instruction
823 just [ { } clone swap curry ] <@ ;
825 : RST-8-instruction ( -- parser )
826 "RST-8" "RST" complex-instruction
828 just [ { } clone swap curry ] <@ ;
830 : RST-10H-instruction ( -- parser )
831 "RST-10H" "RST" complex-instruction
833 just [ { } clone swap curry ] <@ ;
835 : RST-18H-instruction ( -- parser )
836 "RST-18H" "RST" complex-instruction
838 just [ { } clone swap curry ] <@ ;
840 : RST-20H-instruction ( -- parser )
841 "RST-20H" "RST" complex-instruction
843 just [ { } clone swap curry ] <@ ;
845 : RST-28H-instruction ( -- parser )
846 "RST-28H" "RST" complex-instruction
848 just [ { } clone swap curry ] <@ ;
850 : RST-30H-instruction ( -- parser )
851 "RST-30H" "RST" complex-instruction
853 just [ { } clone swap curry ] <@ ;
855 : RST-38H-instruction ( -- parser )
856 "RST-38H" "RST" complex-instruction
858 just [ { } clone swap curry ] <@ ;
860 : JP-NN-instruction ( -- parser )
861 "JP-NN" "JP" complex-instruction
863 just [ { } clone swap curry ] <@ ;
865 : JP-F|FF,NN-instruction ( -- parser )
866 "JP-F|FF,NN" "JP" complex-instruction
869 just [ first2 swap curry ] <@ ;
871 : JP-(RR)-instruction ( -- parser )
872 "JP-(RR)" "JP" complex-instruction
873 16-bit-registers indirect sp <&>
874 just [ first2 swap curry ] <@ ;
876 : CALL-NN-instruction ( -- parser )
877 "CALL-NN" "CALL" complex-instruction
879 just [ { } clone swap curry ] <@ ;
881 : CALL-F|FF,NN-instruction ( -- parser )
882 "CALL-F|FF,NN" "CALL" complex-instruction
885 just [ first2 swap curry ] <@ ;
887 : RLCA-instruction ( -- parser )
888 "RLCA" simple-instruction ;
890 : RRCA-instruction ( -- parser )
891 "RRCA" simple-instruction ;
893 : HALT-instruction ( -- parser )
894 "HALT" simple-instruction ;
896 : DI-instruction ( -- parser )
897 "DI" simple-instruction ;
899 : EI-instruction ( -- parser )
900 "EI" simple-instruction ;
902 : CPL-instruction ( -- parser )
903 "CPL" simple-instruction ;
905 : CCF-instruction ( -- parser )
906 "CCF" simple-instruction ;
908 : SCF-instruction ( -- parser )
909 "SCF" simple-instruction ;
911 : DAA-instruction ( -- parser )
912 "DAA" simple-instruction ;
914 : RLA-instruction ( -- parser )
915 "RLA" simple-instruction ;
917 : RRA-instruction ( -- parser )
918 "RRA" simple-instruction ;
920 : DEC-R-instruction ( -- parser )
921 "DEC-R" "DEC" complex-instruction 8-bit-registers sp <&>
922 just [ first2 swap curry ] <@ ;
924 : DEC-RR-instruction ( -- parser )
925 "DEC-RR" "DEC" complex-instruction 16-bit-registers sp <&>
926 just [ first2 swap curry ] <@ ;
928 : DEC-(RR)-instruction ( -- parser )
929 "DEC-(RR)" "DEC" complex-instruction
930 16-bit-registers indirect sp <&>
931 just [ first2 swap curry ] <@ ;
933 : POP-RR-instruction ( -- parser )
934 "POP-RR" "POP" complex-instruction all-registers sp <&>
935 just [ first2 swap curry ] <@ ;
937 : PUSH-RR-instruction ( -- parser )
938 "PUSH-RR" "PUSH" complex-instruction all-registers sp <&>
939 just [ first2 swap curry ] <@ ;
941 : INC-R-instruction ( -- parser )
942 "INC-R" "INC" complex-instruction 8-bit-registers sp <&>
943 just [ first2 swap curry ] <@ ;
945 : INC-RR-instruction ( -- parser )
946 "INC-RR" "INC" complex-instruction 16-bit-registers sp <&>
947 just [ first2 swap curry ] <@ ;
949 : INC-(RR)-instruction ( -- parser )
950 "INC-(RR)" "INC" complex-instruction
951 all-registers indirect sp <&> just [ first2 swap curry ] <@ ;
953 : RET-F|FF-instruction ( -- parser )
954 "RET-F|FF" "RET" complex-instruction all-flags sp <&>
955 just [ first2 swap curry ] <@ ;
957 : AND-N-instruction ( -- parser )
958 "AND-N" "AND" complex-instruction
960 just [ { } clone swap curry ] <@ ;
962 : AND-R-instruction ( -- parser )
963 "AND-R" "AND" complex-instruction
964 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
966 : AND-(RR)-instruction ( -- parser )
967 "AND-(RR)" "AND" complex-instruction
968 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
970 : XOR-N-instruction ( -- parser )
971 "XOR-N" "XOR" complex-instruction
973 just [ { } clone swap curry ] <@ ;
975 : XOR-R-instruction ( -- parser )
976 "XOR-R" "XOR" complex-instruction
977 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
979 : XOR-(RR)-instruction ( -- parser )
980 "XOR-(RR)" "XOR" complex-instruction
981 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
983 : OR-N-instruction ( -- parser )
984 "OR-N" "OR" complex-instruction
986 just [ { } clone swap curry ] <@ ;
988 : OR-R-instruction ( -- parser )
989 "OR-R" "OR" complex-instruction
990 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
992 : OR-(RR)-instruction ( -- parser )
993 "OR-(RR)" "OR" complex-instruction
994 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
996 : CP-N-instruction ( -- parser )
997 "CP-N" "CP" complex-instruction
999 just [ { } clone swap curry ] <@ ;
1001 : CP-R-instruction ( -- parser )
1002 "CP-R" "CP" complex-instruction
1003 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
1005 : CP-(RR)-instruction ( -- parser )
1006 "CP-(RR)" "CP" complex-instruction
1007 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1009 : ADC-R,N-instruction ( -- parser )
1010 "ADC-R,N" "ADC" complex-instruction
1011 8-bit-registers sp <&>
1013 just [ first2 swap curry ] <@ ;
1015 : ADC-R,R-instruction ( -- parser )
1016 "ADC-R,R" "ADC" complex-instruction
1017 8-bit-registers sp <&>
1020 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1022 : ADC-R,(RR)-instruction ( -- parser )
1023 "ADC-R,(RR)" "ADC" complex-instruction
1024 8-bit-registers sp <&>
1026 16-bit-registers indirect <&>
1027 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1029 : SBC-R,N-instruction ( -- parser )
1030 "SBC-R,N" "SBC" complex-instruction
1031 8-bit-registers sp <&>
1033 just [ first2 swap curry ] <@ ;
1035 : SBC-R,R-instruction ( -- parser )
1036 "SBC-R,R" "SBC" complex-instruction
1037 8-bit-registers sp <&>
1040 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1042 : SBC-R,(RR)-instruction ( -- parser )
1043 "SBC-R,(RR)" "SBC" complex-instruction
1044 8-bit-registers sp <&>
1046 16-bit-registers indirect <&>
1047 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1049 : SUB-R-instruction ( -- parser )
1050 "SUB-R" "SUB" complex-instruction
1051 8-bit-registers sp <&>
1052 just [ first2 swap curry ] <@ ;
1054 : SUB-(RR)-instruction ( -- parser )
1055 "SUB-(RR)" "SUB" complex-instruction
1056 16-bit-registers indirect sp <&>
1057 just [ first2 swap curry ] <@ ;
1059 : SUB-N-instruction ( -- parser )
1060 "SUB-N" "SUB" complex-instruction
1062 just [ { } clone swap curry ] <@ ;
1064 : ADD-R,N-instruction ( -- parser )
1065 "ADD-R,N" "ADD" complex-instruction
1066 8-bit-registers sp <&>
1068 just [ first2 swap curry ] <@ ;
1070 : ADD-R,R-instruction ( -- parser )
1071 "ADD-R,R" "ADD" complex-instruction
1072 8-bit-registers sp <&>
1075 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1077 : ADD-RR,RR-instruction ( -- parser )
1078 "ADD-RR,RR" "ADD" complex-instruction
1079 16-bit-registers sp <&>
1081 16-bit-registers <&>
1082 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1084 : ADD-R,(RR)-instruction ( -- parser )
1085 "ADD-R,(RR)" "ADD" complex-instruction
1086 8-bit-registers sp <&>
1088 16-bit-registers indirect <&>
1089 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1091 : LD-RR,NN-instruction ( -- parser )
1093 "LD-RR,NN" "LD" complex-instruction
1094 16-bit-registers sp <&>
1096 just [ first2 swap curry ] <@ ;
1098 : LD-R,N-instruction ( -- parser )
1100 "LD-R,N" "LD" complex-instruction
1101 8-bit-registers sp <&>
1103 just [ first2 swap curry ] <@ ;
1105 : LD-(RR),N-instruction ( -- parser )
1106 "LD-(RR),N" "LD" complex-instruction
1107 16-bit-registers indirect sp <&>
1109 just [ first2 swap curry ] <@ ;
1111 : LD-(RR),R-instruction ( -- parser )
1113 "LD-(RR),R" "LD" complex-instruction
1114 16-bit-registers indirect sp <&>
1117 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1119 : LD-R,R-instruction ( -- parser )
1120 "LD-R,R" "LD" complex-instruction
1121 8-bit-registers sp <&>
1124 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1126 : LD-RR,RR-instruction ( -- parser )
1127 "LD-RR,RR" "LD" complex-instruction
1128 16-bit-registers sp <&>
1130 16-bit-registers <&>
1131 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1133 : LD-R,(RR)-instruction ( -- parser )
1134 "LD-R,(RR)" "LD" complex-instruction
1135 8-bit-registers sp <&>
1137 16-bit-registers indirect <&>
1138 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1140 : LD-(NN),RR-instruction ( -- parser )
1141 "LD-(NN),RR" "LD" complex-instruction
1142 "nn" token indirect sp <&
1144 16-bit-registers <&>
1145 just [ first2 swap curry ] <@ ;
1147 : LD-(NN),R-instruction ( -- parser )
1148 "LD-(NN),R" "LD" complex-instruction
1149 "nn" token indirect sp <&
1152 just [ first2 swap curry ] <@ ;
1154 : LD-RR,(NN)-instruction ( -- parser )
1155 "LD-RR,(NN)" "LD" complex-instruction
1156 16-bit-registers sp <&>
1158 "nn" token indirect <&
1159 just [ first2 swap curry ] <@ ;
1161 : LD-R,(NN)-instruction ( -- parser )
1162 "LD-R,(NN)" "LD" complex-instruction
1163 8-bit-registers sp <&>
1165 "nn" token indirect <&
1166 just [ first2 swap curry ] <@ ;
1168 : OUT-(N),R-instruction ( -- parser )
1169 "OUT-(N),R" "OUT" complex-instruction
1170 "n" token indirect sp <&
1173 just [ first2 swap curry ] <@ ;
1175 : IN-R,(N)-instruction ( -- parser )
1176 "IN-R,(N)" "IN" complex-instruction
1177 8-bit-registers sp <&>
1179 "n" token indirect <&
1180 just [ first2 swap curry ] <@ ;
1182 : EX-(RR),RR-instruction ( -- parser )
1183 "EX-(RR),RR" "EX" complex-instruction
1184 16-bit-registers indirect sp <&>
1186 16-bit-registers <&>
1187 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1189 : EX-RR,RR-instruction ( -- parser )
1190 "EX-RR,RR" "EX" complex-instruction
1191 16-bit-registers sp <&>
1193 16-bit-registers <&>
1194 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1196 : 8080-generator-parser ( -- parser )
1198 RST-0-instruction <|>
1199 RST-8-instruction <|>
1200 RST-10H-instruction <|>
1201 RST-18H-instruction <|>
1202 RST-20H-instruction <|>
1203 RST-28H-instruction <|>
1204 RST-30H-instruction <|>
1205 RST-38H-instruction <|>
1206 JP-F|FF,NN-instruction <|>
1207 JP-NN-instruction <|>
1208 JP-(RR)-instruction <|>
1209 CALL-F|FF,NN-instruction <|>
1210 CALL-NN-instruction <|>
1217 RLCA-instruction <|>
1218 RRCA-instruction <|>
1219 HALT-instruction <|>
1222 AND-N-instruction <|>
1223 AND-R-instruction <|>
1224 AND-(RR)-instruction <|>
1225 XOR-N-instruction <|>
1226 XOR-R-instruction <|>
1227 XOR-(RR)-instruction <|>
1228 OR-N-instruction <|>
1229 OR-R-instruction <|>
1230 OR-(RR)-instruction <|>
1231 CP-N-instruction <|>
1232 CP-R-instruction <|>
1233 CP-(RR)-instruction <|>
1234 DEC-RR-instruction <|>
1235 DEC-R-instruction <|>
1236 DEC-(RR)-instruction <|>
1237 POP-RR-instruction <|>
1238 PUSH-RR-instruction <|>
1239 INC-RR-instruction <|>
1240 INC-R-instruction <|>
1241 INC-(RR)-instruction <|>
1242 LD-RR,NN-instruction <|>
1243 LD-R,N-instruction <|>
1244 LD-R,R-instruction <|>
1245 LD-RR,RR-instruction <|>
1246 LD-(RR),N-instruction <|>
1247 LD-(RR),R-instruction <|>
1248 LD-R,(RR)-instruction <|>
1249 LD-(NN),RR-instruction <|>
1250 LD-(NN),R-instruction <|>
1251 LD-RR,(NN)-instruction <|>
1252 LD-R,(NN)-instruction <|>
1253 ADC-R,N-instruction <|>
1254 ADC-R,R-instruction <|>
1255 ADC-R,(RR)-instruction <|>
1256 ADD-R,N-instruction <|>
1257 ADD-R,R-instruction <|>
1258 ADD-RR,RR-instruction <|>
1259 ADD-R,(RR)-instruction <|>
1260 SBC-R,N-instruction <|>
1261 SBC-R,R-instruction <|>
1262 SBC-R,(RR)-instruction <|>
1263 SUB-R-instruction <|>
1264 SUB-(RR)-instruction <|>
1265 SUB-N-instruction <|>
1266 RET-F|FF-instruction <|>
1267 RET-NN-instruction <|>
1268 OUT-(N),R-instruction <|>
1269 IN-R,(N)-instruction <|>
1270 EX-(RR),RR-instruction <|>
1271 EX-RR,RR-instruction <|>
1274 : instruction-quotations ( string -- emulate-quot )
1275 #! Given an instruction string, return the emulation quotation for
1276 #! it. This will later be expanded to produce the disassembly and
1277 #! assembly quotations.
1278 8080-generator-parser some parse call ;
1280 SYMBOL: last-instruction
1283 : parse-instructions ( list -- emulate-quot )
1284 #! Process the list of strings, which should make
1285 #! up an 8080 instruction, and output a quotation
1286 #! that would implement that instruction.
1287 dup " " join instruction-quotations
1288 >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
1289 r> (( cpu -- )) define-declared ;
1291 : INSTRUCTION: ";" parse-tokens parse-instructions ; parsing
1294 #! Set the number of cycles for the last instruction that was defined.
1295 scan string>number last-opcode global at instruction-cycles set-nth ; parsing
1298 #! Set the opcode number for the last instruction that was defined.
1299 last-instruction global at 1quotation scan 16 base>
1300 dup last-opcode global set-at set-instruction ; parsing