1 ! Copyright (C) 2006 Chris Double.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: kernel math sequences words arrays io io.files namespaces
5 math.parser assocs quotations parser parser-combinators
6 tools.time io.encodings.binary sequences.deep symbols combinators ;
9 TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
11 GENERIC: reset ( cpu -- )
12 GENERIC: update-video ( value addr cpu -- )
13 GENERIC: read-port ( port cpu -- byte )
14 GENERIC: write-port ( value port cpu -- )
16 M: cpu update-video ( value addr cpu -- )
19 M: cpu read-port ( port cpu -- byte )
20 #! Read a byte from the hardware port. 'port' should
24 M: cpu write-port ( value port cpu -- )
25 #! Write a byte to the hardware port, where 'port' is
29 : carry-flag HEX: 01 ; inline
30 : parity-flag HEX: 04 ; inline
31 : half-carry-flag HEX: 10 ; inline
32 : interrupt-flag HEX: 20 ; inline
33 : zero-flag HEX: 40 ; inline
34 : sign-flag HEX: 80 ; inline
36 : >word< ( word -- byte byte )
37 #! Explode a word into its two 8 bit values.
38 dup HEX: FF bitand swap -8 shift HEX: FF bitand swap ;
40 : cpu-af ( cpu -- word )
41 #! Return the 16-bit pseudo register AF.
42 [ cpu-a 8 shift ] keep cpu-f bitor ;
44 : set-cpu-af ( value cpu -- )
45 #! Set the value of the 16-bit pseudo register AF
46 >r >word< r> tuck set-cpu-f set-cpu-a ;
48 : cpu-bc ( cpu -- word )
49 #! Return the 16-bit pseudo register BC.
50 [ cpu-b 8 shift ] keep cpu-c bitor ;
52 : set-cpu-bc ( value cpu -- )
53 #! Set the value of the 16-bit pseudo register BC
54 >r >word< r> tuck set-cpu-c set-cpu-b ;
56 : cpu-de ( cpu -- word )
57 #! Return the 16-bit pseudo register DE.
58 [ cpu-d 8 shift ] keep cpu-e bitor ;
60 : set-cpu-de ( value cpu -- )
61 #! Set the value of the 16-bit pseudo register DE
62 >r >word< r> tuck set-cpu-e set-cpu-d ;
64 : cpu-hl ( cpu -- word )
65 #! Return the 16-bit pseudo register HL.
66 [ cpu-h 8 shift ] keep cpu-l bitor ;
68 : set-cpu-hl ( value cpu -- )
69 #! Set the value of the 16-bit pseudo register HL
70 >r >word< r> tuck set-cpu-l set-cpu-h ;
72 : flag-set? ( flag cpu -- bool )
73 cpu-f bitand 0 = not ;
75 : flag-clear? ( flag cpu -- bool )
78 : flag-nz? ( cpu -- bool )
80 cpu-f zero-flag bitand 0 = ;
82 : flag-z? ( cpu -- bool )
84 cpu-f zero-flag bitand 0 = not ;
86 : flag-nc? ( cpu -- bool )
88 cpu-f carry-flag bitand 0 = ;
90 : flag-c? ( cpu -- bool )
92 cpu-f carry-flag bitand 0 = not ;
94 : flag-po? ( cpu -- bool )
96 cpu-f parity-flag bitand 0 = ;
98 : flag-pe? ( cpu -- bool )
100 cpu-f parity-flag bitand 0 = not ;
102 : flag-p? ( cpu -- bool )
104 cpu-f sign-flag bitand 0 = ;
106 : flag-m? ( cpu -- bool )
108 cpu-f sign-flag bitand 0 = not ;
110 : read-byte ( addr cpu -- byte )
111 #! Read one byte from memory at the specified address.
112 #! The address is 16-bit, but if a value greater than
113 #! 0xFFFF is provided then return a default value.
120 : read-word ( addr cpu -- word )
121 #! Read a 16-bit word from memory at the specified address.
122 #! The address is 16-bit, but if a value greater than
123 #! 0xFFFF is provided then return a default value.
124 [ read-byte ] 2keep >r 1 + r> read-byte 8 shift bitor ;
126 : next-byte ( cpu -- byte )
127 #! Return the value of the byte at PC, and increment PC.
133 : next-word ( cpu -- word )
134 #! Return the value of the word at PC, and increment PC.
141 : write-byte ( value addr cpu -- )
142 #! Write a byte to the specified memory address.
143 over dup HEX: 2000 < swap HEX: FFFF > or [
151 : write-word ( value addr cpu -- )
152 #! Write a 16-bit word to the specified memory address.
153 >r >r >word< r> r> [ write-byte ] 2keep >r 1 + r> write-byte ;
155 : cpu-a-bitand ( quot cpu -- )
157 [ cpu-a swap call bitand ] keep set-cpu-a ; inline
159 : cpu-a-bitor ( quot cpu -- )
161 [ cpu-a swap call bitor ] keep set-cpu-a ; inline
163 : cpu-a-bitxor ( quot cpu -- )
165 [ cpu-a swap call bitxor ] keep set-cpu-a ; inline
167 : cpu-a-bitxor= ( value cpu -- )
169 [ cpu-a bitxor ] keep set-cpu-a ;
171 : cpu-f-bitand ( quot cpu -- )
173 [ cpu-f swap call bitand ] keep set-cpu-f ; inline
175 : cpu-f-bitor ( quot cpu -- )
177 [ cpu-f swap call bitor ] keep set-cpu-f ; inline
179 : cpu-f-bitxor ( quot cpu -- )
181 [ cpu-f swap call bitxor ] keep set-cpu-f ; inline
183 : cpu-f-bitor= ( value cpu -- )
185 [ cpu-f bitor ] keep set-cpu-f ;
187 : cpu-f-bitand= ( value cpu -- )
189 [ cpu-f bitand ] keep set-cpu-f ;
191 : cpu-f-bitxor= ( value cpu -- )
193 [ cpu-f bitxor ] keep set-cpu-f ;
195 : set-flag ( cpu flag -- )
198 : clear-flag ( cpu flag -- )
199 bitnot HEX: FF bitand swap cpu-f-bitand= ;
201 : update-zero-flag ( result cpu -- )
202 #! If the result of an instruction has the value 0, this
203 #! flag is set, otherwise it is reset.
204 swap HEX: FF bitand 0 = [ zero-flag set-flag ] [ zero-flag clear-flag ] if ;
206 : update-sign-flag ( result cpu -- )
207 #! If the most significant bit of the result
208 #! has the value 1 then the flag is set, otherwise
210 swap HEX: 80 bitand 0 = [ sign-flag clear-flag ] [ sign-flag set-flag ] if ;
212 : update-parity-flag ( result cpu -- )
213 #! If the modulo 2 sum of the bits of the result
214 #! is 0, (ie. if the result has even parity) this flag
215 #! is set, otherwise it is reset.
216 swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] if ;
218 : update-carry-flag ( result cpu -- )
219 #! If the instruction resulted in a carry (from addition)
220 #! or a borrow (from subtraction or a comparison) out of the
221 #! higher order bit, this flag is set, otherwise it is reset.
222 swap dup HEX: 100 >= swap 0 < or [ carry-flag set-flag ] [ carry-flag clear-flag ] if ;
224 : update-half-carry-flag ( original change-by result cpu -- )
225 #! If the instruction caused a carry out of bit 3 and into bit 4 of the
226 #! resulting value, the half carry flag is set, otherwise it is reset.
227 #! The 'original' is the original value of the register being changed.
228 #! 'change-by' is the amount it is being added or decremented by.
229 #! 'result' is the result of that change.
230 >r bitxor bitxor HEX: 10 bitand 0 = not r>
231 swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ;
233 : update-flags ( result cpu -- )
234 2dup update-carry-flag
235 2dup update-parity-flag
236 2dup update-sign-flag
239 : update-flags-no-carry ( result cpu -- )
240 2dup update-parity-flag
241 2dup update-sign-flag
244 : add-byte ( lhs rhs cpu -- result )
246 >r 2dup + r> ! lhs rhs result cpu
247 [ update-flags ] 2keep
248 [ update-half-carry-flag ] 2keep
249 drop HEX: FF bitand ;
251 : add-carry ( change-by result cpu -- change-by result )
252 #! Add the effect of the carry flag to the result
253 flag-c? [ 1 + >r 1 + r> ] when ;
255 : add-byte-with-carry ( lhs rhs cpu -- result )
256 #! Add rhs to lhs plus carry.
257 >r 2dup + r> ! lhs rhs result cpu
259 [ update-flags ] 2keep
260 [ update-half-carry-flag ] 2keep
261 drop HEX: FF bitand ;
263 : sub-carry ( change-by result cpu -- change-by result )
264 #! Subtract the effect of the carry flag from the result
265 flag-c? [ 1 - >r 1 - r> ] when ;
267 : sub-byte ( lhs rhs cpu -- result )
268 #! Subtract rhs from lhs
270 [ update-flags ] 2keep
271 [ update-half-carry-flag ] 2keep
272 drop HEX: FF bitand ;
274 : sub-byte-with-carry ( lhs rhs cpu -- result )
275 #! Subtract rhs from lhs and take carry into account
278 [ update-flags ] 2keep
279 [ update-half-carry-flag ] 2keep
280 drop HEX: FF bitand ;
282 : inc-byte ( byte cpu -- result )
283 #! Increment byte by one. Note that carry flag is not affected
284 #! by this operation.
285 >r 1 2dup + r> ! lhs rhs result cpu
286 [ update-flags-no-carry ] 2keep
287 [ update-half-carry-flag ] 2keep
288 drop HEX: FF bitand ;
290 : dec-byte ( byte cpu -- result )
291 #! Decrement byte by one. Note that carry flag is not affected
292 #! by this operation.
293 >r 1 2dup - r> ! lhs rhs result cpu
294 [ update-flags-no-carry ] 2keep
295 [ update-half-carry-flag ] 2keep
296 drop HEX: FF bitand ;
298 : inc-word ( w cpu -- w )
299 #! Increment word by one. Note that no flags are modified.
300 drop 1 + HEX: FFFF bitand ;
302 : dec-word ( w cpu -- w )
303 #! Decrement word by one. Note that no flags are modified.
304 drop 1 - HEX: FFFF bitand ;
306 : add-word ( lhs rhs cpu -- result )
307 #! Add rhs to lhs. Note that only the carry flag is modified
308 #! and only if there is a carry out of the double precision add.
309 >r + r> over HEX: FFFF > [ carry-flag set-flag ] [ drop ] if HEX: FFFF bitand ;
311 : bit3or ( lhs rhs -- 0|1 )
312 #! bitor bit 3 of the two numbers on the stack
313 BIN: 00001000 bitand -3 shift >r
314 BIN: 00001000 bitand -3 shift r>
317 : and-byte ( lhs rhs cpu -- result )
318 #! Logically and rhs to lhs. The carry flag is cleared and
319 #! the half carry is set to the ORing of bits 3 of the operands.
320 [ drop bit3or ] 3keep ! bit3or lhs rhs cpu
321 >r bitand r> [ update-flags ] 2keep
322 [ carry-flag clear-flag ] keep
323 rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if
326 : xor-byte ( lhs rhs cpu -- result )
327 #! Logically xor rhs to lhs. The carry and half-carry flags are cleared.
328 >r bitxor r> [ update-flags ] 2keep
329 [ half-carry-flag carry-flag bitor clear-flag ] keep
330 drop HEX: FF bitand ;
332 : or-byte ( lhs rhs cpu -- result )
333 #! Logically or rhs to lhs. The carry and half-carry flags are cleared.
334 >r bitor r> [ update-flags ] 2keep
335 [ half-carry-flag carry-flag bitor clear-flag ] keep
336 drop HEX: FF bitand ;
338 : flags ( seq -- seq )
339 [ 0 [ execute bitor ] reduce ] map ;
341 : decrement-sp ( n cpu -- )
342 #! Decrement the stackpointer by n.
344 >r swap - r> set-cpu-sp ;
347 #! Save the value of the PC on the stack.
348 [ cpu-pc ] keep ! pc cpu
349 [ cpu-sp ] keep ! pc sp cpu
353 #! Push the value of the PC on the stack.
357 : pop-pc ( cpu -- pc )
358 #! Pop the value of the PC off the stack.
361 -2 swap decrement-sp ;
363 : push-sp ( value cpu -- )
364 [ 2 swap decrement-sp ] keep
368 : pop-sp ( cpu -- value )
371 -2 swap decrement-sp ;
373 : call-sub ( addr cpu -- )
374 #! Call the address as a subroutine.
376 >r HEX: FFFF bitand r> set-cpu-pc ;
378 : ret-from-sub ( cpu -- )
379 [ pop-pc ] keep set-cpu-pc ;
381 : interrupt ( number cpu -- )
382 #! Perform a hardware interrupt
383 ! "***Interrupt: " write over 16 >base print
384 dup cpu-f interrupt-flag bitand 0 = not [
391 : inc-cycles ( n cpu -- )
392 #! Increment the number of cpu cycles
393 [ cpu-cycles + ] keep set-cpu-cycles ;
395 : instruction-cycles ( -- vector )
396 #! Return a 256 element vector containing the cycles for
397 #! each opcode in the 8080 instruction set.
398 << 256 f <array> parsed >> ;
400 : not-implemented ( <cpu> -- )
403 : instructions ( -- vector )
404 #! Return a 256 element vector containing the emulation words for
405 #! each opcode in the 8080 instruction set.
406 << 256 [ [ not-implemented ] 2array ] map parsed >> ; inline
408 : set-instruction ( quot n -- )
409 tuck >r 2array r> instructions set-nth ;
411 M: cpu reset ( cpu -- )
412 #! Reset the CPU to its poweron state
413 [ 0 swap set-cpu-b ] keep
414 [ 0 swap set-cpu-c ] keep
415 [ 0 swap set-cpu-d ] keep
416 [ 0 swap set-cpu-e ] keep
417 [ 0 swap set-cpu-h ] keep
418 [ 0 swap set-cpu-l ] keep
419 [ 0 swap set-cpu-a ] keep
420 [ 0 swap set-cpu-f ] keep
421 [ 0 swap set-cpu-pc ] keep
422 [ HEX: F000 swap set-cpu-sp ] keep
423 [ HEX: FFFF 0 <array> swap set-cpu-ram ] keep
424 [ f swap set-cpu-halted? ] keep
425 [ HEX: 10 swap set-cpu-last-interrupt ] keep
426 0 swap set-cpu-cycles ;
428 : <cpu> ( -- cpu ) cpu new dup reset ;
430 : (load-rom) ( n ram -- )
432 -rot [ set-nth ] 2keep >r 1 + r> (load-rom)
437 #! Reads the ROM from stdin and stores it in ROM from
439 : load-rom ( filename cpu -- )
440 #! Load the contents of the file into ROM.
441 #! (address 0x0000-0x1FFF).
442 cpu-ram swap binary [
448 : rom-dir ( -- string )
449 rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ;
451 : load-rom* ( seq cpu -- )
452 #! 'seq' is an array of arrays. Each array contains
453 #! an address and filename of a ROM file. The ROM
454 #! file will be loaded at the specified address. This
455 #! file path shoul dbe relative to the '/roms' resource path.
458 swap first2 rom-dir prepend-path binary [
465 "Set 'rom-root' to the path containing the root of the 8080 ROM files." throw
468 : read-instruction ( cpu -- word )
469 #! Read the next instruction from the cpu's program
470 #! counter, and increment the program counter.
471 [ cpu-pc ] keep ! pc cpu
472 [ over 1 + swap set-cpu-pc ] keep
475 : get-cycles ( n -- opcode )
476 #! Returns the cycles for the given instruction value.
477 #! If the opcode is not defined throw an error.
478 dup instruction-cycles nth [
481 [ "Undefined 8080 opcode: " % number>string % ] "" make throw
484 : process-interrupts ( cpu -- )
485 #! Process any hardware interrupts
490 [ >r 16667 - r> set-cpu-cycles ] keep
491 dup cpu-last-interrupt HEX: 10 = [
492 HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt
494 HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt
498 : peek-instruction ( cpu -- word )
499 #! Return the next instruction from the cpu's program
500 #! counter, but don't increment the counter.
501 [ cpu-pc ] keep read-byte instructions nth first ;
504 [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
505 [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
506 [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
507 [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
508 [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
509 [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
510 [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
511 [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
512 [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
513 [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
514 [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
515 [ " " write peek-instruction word-name write " " write ] keep
519 [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
520 [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
521 [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
522 [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
523 [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
524 [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
525 [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
526 [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
527 [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
528 [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
529 [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
532 : register-lookup ( string -- vector )
533 #! Given a string containing a register name, return a vector
534 #! where the 1st item is the getter and the 2nd is the setter
535 #! for that register.
537 { "A" { cpu-a set-cpu-a } }
538 { "B" { cpu-b set-cpu-b } }
539 { "C" { cpu-c set-cpu-c } }
540 { "D" { cpu-d set-cpu-d } }
541 { "E" { cpu-e set-cpu-e } }
542 { "H" { cpu-h set-cpu-h } }
543 { "L" { cpu-l set-cpu-l } }
544 { "AF" { cpu-af set-cpu-af } }
545 { "BC" { cpu-bc set-cpu-bc } }
546 { "DE" { cpu-de set-cpu-de } }
547 { "HL" { cpu-hl set-cpu-hl } }
548 { "SP" { cpu-sp set-cpu-sp } }
552 : flag-lookup ( string -- vector )
553 #! Given a string containing a flag name, return a vector
554 #! where the 1st item is a word that tests that flag.
556 { "NZ" { flag-nz? } }
557 { "NC" { flag-nc? } }
558 { "PO" { flag-po? } }
559 { "PE" { flag-pe? } }
566 SYMBOLS: $1 $2 $3 $4 ;
568 : replace-patterns ( vector tree -- tree )
579 : (emulate-RST) ( n cpu -- )
581 [ cpu-sp 2 - dup ] keep ! sp sp cpu
582 [ set-cpu-sp ] keep ! sp cpu
583 [ cpu-pc ] keep ! sp pc cpu
584 swapd [ write-word ] keep ! cpu
585 >r 8 * r> set-cpu-pc ;
587 : (emulate-CALL) ( cpu -- )
589 [ next-word HEX: FFFF bitand ] keep ! addr cpu
590 [ cpu-sp 2 - dup ] keep ! addr sp sp cpu
591 [ set-cpu-sp ] keep ! addr sp cpu
592 [ cpu-pc ] keep ! addr sp pc cpu
593 swapd [ write-word ] keep ! addr cpu
596 : (emulate-RLCA) ( cpu -- )
597 #! The content of the accumulator is rotated left
598 #! one position. The low order bit and the carry flag
599 #! are both set to the value shifd out of the high
600 #! order bit position. Only the carry flag is affected.
601 [ cpu-a -7 shift ] keep
602 over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
603 [ cpu-a 1 shift HEX: FF bitand ] keep
604 >r bitor r> set-cpu-a ;
606 : (emulate-RRCA) ( cpu -- )
607 #! The content of the accumulator is rotated right
608 #! one position. The high order bit and the carry flag
609 #! are both set to the value shifd out of the low
610 #! order bit position. Only the carry flag is affected.
611 [ cpu-a 1 bitand 7 shift ] keep
612 over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
613 [ cpu-a 254 bitand -1 shift ] keep
614 >r bitor r> set-cpu-a ;
616 : (emulate-RLA) ( cpu -- )
617 #! The content of the accumulator is rotated left
618 #! one position through the carry flag. The low
619 #! order bit is set equal to the carry flag and
620 #! the carry flag is set to the value shifd out
621 #! of the high order bit. Only the carry flag is
623 [ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
624 [ cpu-a 127 bitand 7 shift ] keep
625 dup cpu-a 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
626 >r bitor r> set-cpu-a ;
628 : (emulate-RRA) ( cpu -- )
629 #! The content of the accumulator is rotated right
630 #! one position through the carry flag. The high order
631 #! bit is set to the carry flag and the carry flag is
632 #! set to the value shifd out of the low order bit.
633 #! Only the carry flag is affected.
634 [ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep
635 [ cpu-a 254 bitand -1 shift ] keep
636 dup cpu-a 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
637 >r bitor r> set-cpu-a ;
639 : (emulate-CPL) ( cpu -- )
640 #! The contents of the accumulator are complemented
641 #! (zero bits become one, one bits becomes zero).
642 #! No flags are affected.
643 HEX: FF swap cpu-a-bitxor= ;
645 : (emulate-DAA) ( cpu -- )
646 #! The eight bit number in the accumulator is
647 #! adjusted to form two four-bit binary-coded-decimal
650 dup half-carry-flag swap flag-set? swap
651 cpu-a BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] if
654 [ update-flags ] 2keep
655 [ swap HEX: FF bitand swap set-cpu-a ] keep
657 dup carry-flag swap flag-set? swap
658 cpu-a -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if
661 [ update-flags ] 2keep
662 swap HEX: FF bitand swap set-cpu-a ;
664 : patterns ( -- hashtable )
665 #! table of code quotation patterns for each type of instruction.
668 { "RET-NN" [ ret-from-sub ] }
669 { "RST-0" [ 0 swap (emulate-RST) ] }
670 { "RST-8" [ 8 swap (emulate-RST) ] }
671 { "RST-10H" [ HEX: 10 swap (emulate-RST) ] }
672 { "RST-18H" [ HEX: 18 swap (emulate-RST) ] }
673 { "RST-20H" [ HEX: 20 swap (emulate-RST) ] }
674 { "RST-28H" [ HEX: 28 swap (emulate-RST) ] }
675 { "RST-30H" [ HEX: 30 swap (emulate-RST) ] }
676 { "RST-38H" [ HEX: 38 swap (emulate-RST) ] }
677 { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
678 { "CP-N" [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] }
679 { "CP-R" [ [ cpu-a ] keep [ $1 ] keep sub-byte drop ] }
680 { "CP-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] }
681 { "OR-N" [ [ cpu-a ] keep [ next-byte ] keep [ or-byte ] keep set-cpu-a ] }
682 { "OR-R" [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] }
683 { "OR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a ] }
684 { "XOR-N" [ [ cpu-a ] keep [ next-byte ] keep [ xor-byte ] keep set-cpu-a ] }
685 { "XOR-R" [ [ cpu-a ] keep [ $1 ] keep [ xor-byte ] keep set-cpu-a ] }
686 { "XOR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep set-cpu-a ] }
687 { "AND-N" [ [ cpu-a ] keep [ next-byte ] keep [ and-byte ] keep set-cpu-a ] }
688 { "AND-R" [ [ cpu-a ] keep [ $1 ] keep [ and-byte ] keep set-cpu-a ] }
689 { "AND-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep set-cpu-a ] }
690 { "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] }
691 { "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] }
692 { "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] }
693 { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] }
694 { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] }
695 { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] }
696 { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] }
697 { "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
698 { "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] }
699 { "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
700 { "SUB-R" [ [ cpu-a ] keep [ $1 ] keep [ sub-byte ] keep set-cpu-a ] }
701 { "SUB-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep set-cpu-a ] }
702 { "SUB-N" [ [ cpu-a ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] }
703 { "CPL" [ (emulate-CPL) ] }
704 { "DAA" [ (emulate-DAA) ] }
705 { "RLA" [ (emulate-RLA) ] }
706 { "RRA" [ (emulate-RRA) ] }
707 { "CCF" [ carry-flag swap cpu-f-bitxor= ] }
708 { "SCF" [ carry-flag swap cpu-f-bitor= ] }
709 { "RLCA" [ (emulate-RLCA) ] }
710 { "RRCA" [ (emulate-RRCA) ] }
712 { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] }
713 { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] }
714 { "POP-RR" [ [ pop-sp ] keep $2 ] }
715 { "PUSH-RR" [ [ $1 ] keep push-sp ] }
716 { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] }
717 { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] }
718 { "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] }
719 { "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] }
720 { "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] }
721 { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] }
722 { "JP-NN" [ [ cpu-pc ] keep [ read-word ] keep set-cpu-pc ] }
723 { "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 ] }
724 { "JP-(RR)" [ [ $1 ] keep set-cpu-pc ] }
725 { "CALL-NN" [ (emulate-CALL) ] }
726 { "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] }
727 { "LD-RR,NN" [ [ next-word ] keep $2 ] }
728 { "LD-RR,RR" [ [ $3 ] keep $2 ] }
729 { "LD-R,N" [ [ next-byte ] keep $2 ] }
730 { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] }
731 { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] }
732 { "LD-R,R" [ [ $3 ] keep $2 ] }
733 { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] }
734 { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] }
735 { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] }
736 { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] }
737 { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] }
738 { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] }
739 { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] }
740 { "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] }
741 { "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
744 : 8-bit-registers ( -- parser )
745 #! A parser for 8-bit registers. On a successfull parse the
746 #! parse tree contains a vector. The first item in the vector
747 #! is the getter word for that register with stack effect
748 #! ( cpu -- value ). The second item is the setter word with
749 #! stack effect ( value cpu -- ).
756 "L" token <|> [ register-lookup ] <@ ;
758 : all-flags ( -- parser )
759 #! A parser for 16-bit flags.
767 "M" token <|> [ flag-lookup ] <@ ;
769 : 16-bit-registers ( -- parser )
770 #! A parser for 16-bit registers. On a successfull parse the
771 #! parse tree contains a vector. The first item in the vector
772 #! is the getter word for that register with stack effect
773 #! ( cpu -- value ). The second item is the setter word with
774 #! stack effect ( value cpu -- ).
779 "SP" token <|> [ register-lookup ] <@ ;
781 : all-registers ( -- parser )
782 #! Return a parser that can parse the format
783 #! for 8 bit or 16 bit registers.
784 8-bit-registers 16-bit-registers <|> ;
786 : indirect ( parser -- parser )
787 #! Given a parser, return a parser which parses the original
788 #! wrapped in brackets, representing an indirect reference.
789 #! eg. BC -> (BC). The value of the original parser is left in
791 "(" token swap &> ")" token <& ;
793 : generate-instruction ( vector string -- quot )
794 #! Generate the quotation for an instruction, given the instruction in
795 #! the 'string' and a vector containing the arguments for that instruction.
796 patterns at replace-patterns ;
798 : simple-instruction ( token -- parser )
799 #! Return a parser for then instruction identified by the token.
800 #! The parser return parses the token only and expects no additional
801 #! arguments to the instruction.
802 token [ [ { } clone , , \ generate-instruction , ] [ ] make ] <@ ;
804 : complex-instruction ( type token -- parser )
805 #! Return a parser for an instruction identified by the token.
806 #! The instruction is expected to take additional arguments by
807 #! being combined with other parsers. Then 'type' is used for a lookup
808 #! in a pattern hashtable to return the instruction quotation pattern.
809 token swap [ nip [ , \ generate-instruction , ] [ ] make ] curry <@ ;
811 : NOP-instruction ( -- parser )
812 "NOP" simple-instruction ;
814 : RET-NN-instruction ( -- parser )
815 "RET-NN" "RET" complex-instruction
817 just [ { } clone swap curry ] <@ ;
819 : RST-0-instruction ( -- parser )
820 "RST-0" "RST" complex-instruction
822 just [ { } clone swap curry ] <@ ;
824 : RST-8-instruction ( -- parser )
825 "RST-8" "RST" complex-instruction
827 just [ { } clone swap curry ] <@ ;
829 : RST-10H-instruction ( -- parser )
830 "RST-10H" "RST" complex-instruction
832 just [ { } clone swap curry ] <@ ;
834 : RST-18H-instruction ( -- parser )
835 "RST-18H" "RST" complex-instruction
837 just [ { } clone swap curry ] <@ ;
839 : RST-20H-instruction ( -- parser )
840 "RST-20H" "RST" complex-instruction
842 just [ { } clone swap curry ] <@ ;
844 : RST-28H-instruction ( -- parser )
845 "RST-28H" "RST" complex-instruction
847 just [ { } clone swap curry ] <@ ;
849 : RST-30H-instruction ( -- parser )
850 "RST-30H" "RST" complex-instruction
852 just [ { } clone swap curry ] <@ ;
854 : RST-38H-instruction ( -- parser )
855 "RST-38H" "RST" complex-instruction
857 just [ { } clone swap curry ] <@ ;
859 : JP-NN-instruction ( -- parser )
860 "JP-NN" "JP" complex-instruction
862 just [ { } clone swap curry ] <@ ;
864 : JP-F|FF,NN-instruction ( -- parser )
865 "JP-F|FF,NN" "JP" complex-instruction
868 just [ first2 swap curry ] <@ ;
870 : JP-(RR)-instruction ( -- parser )
871 "JP-(RR)" "JP" complex-instruction
872 16-bit-registers indirect sp <&>
873 just [ first2 swap curry ] <@ ;
875 : CALL-NN-instruction ( -- parser )
876 "CALL-NN" "CALL" complex-instruction
878 just [ { } clone swap curry ] <@ ;
880 : CALL-F|FF,NN-instruction ( -- parser )
881 "CALL-F|FF,NN" "CALL" complex-instruction
884 just [ first2 swap curry ] <@ ;
886 : RLCA-instruction ( -- parser )
887 "RLCA" simple-instruction ;
889 : RRCA-instruction ( -- parser )
890 "RRCA" simple-instruction ;
892 : HALT-instruction ( -- parser )
893 "HALT" simple-instruction ;
895 : DI-instruction ( -- parser )
896 "DI" simple-instruction ;
898 : EI-instruction ( -- parser )
899 "EI" simple-instruction ;
901 : CPL-instruction ( -- parser )
902 "CPL" simple-instruction ;
904 : CCF-instruction ( -- parser )
905 "CCF" simple-instruction ;
907 : SCF-instruction ( -- parser )
908 "SCF" simple-instruction ;
910 : DAA-instruction ( -- parser )
911 "DAA" simple-instruction ;
913 : RLA-instruction ( -- parser )
914 "RLA" simple-instruction ;
916 : RRA-instruction ( -- parser )
917 "RRA" simple-instruction ;
919 : DEC-R-instruction ( -- parser )
920 "DEC-R" "DEC" complex-instruction 8-bit-registers sp <&>
921 just [ first2 swap curry ] <@ ;
923 : DEC-RR-instruction ( -- parser )
924 "DEC-RR" "DEC" complex-instruction 16-bit-registers sp <&>
925 just [ first2 swap curry ] <@ ;
927 : DEC-(RR)-instruction ( -- parser )
928 "DEC-(RR)" "DEC" complex-instruction
929 16-bit-registers indirect sp <&>
930 just [ first2 swap curry ] <@ ;
932 : POP-RR-instruction ( -- parser )
933 "POP-RR" "POP" complex-instruction all-registers sp <&>
934 just [ first2 swap curry ] <@ ;
936 : PUSH-RR-instruction ( -- parser )
937 "PUSH-RR" "PUSH" complex-instruction all-registers sp <&>
938 just [ first2 swap curry ] <@ ;
940 : INC-R-instruction ( -- parser )
941 "INC-R" "INC" complex-instruction 8-bit-registers sp <&>
942 just [ first2 swap curry ] <@ ;
944 : INC-RR-instruction ( -- parser )
945 "INC-RR" "INC" complex-instruction 16-bit-registers sp <&>
946 just [ first2 swap curry ] <@ ;
948 : INC-(RR)-instruction ( -- parser )
949 "INC-(RR)" "INC" complex-instruction
950 all-registers indirect sp <&> just [ first2 swap curry ] <@ ;
952 : RET-F|FF-instruction ( -- parser )
953 "RET-F|FF" "RET" complex-instruction all-flags sp <&>
954 just [ first2 swap curry ] <@ ;
956 : AND-N-instruction ( -- parser )
957 "AND-N" "AND" complex-instruction
959 just [ { } clone swap curry ] <@ ;
961 : AND-R-instruction ( -- parser )
962 "AND-R" "AND" complex-instruction
963 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
965 : AND-(RR)-instruction ( -- parser )
966 "AND-(RR)" "AND" complex-instruction
967 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
969 : XOR-N-instruction ( -- parser )
970 "XOR-N" "XOR" complex-instruction
972 just [ { } clone swap curry ] <@ ;
974 : XOR-R-instruction ( -- parser )
975 "XOR-R" "XOR" complex-instruction
976 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
978 : XOR-(RR)-instruction ( -- parser )
979 "XOR-(RR)" "XOR" complex-instruction
980 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
982 : OR-N-instruction ( -- parser )
983 "OR-N" "OR" complex-instruction
985 just [ { } clone swap curry ] <@ ;
987 : OR-R-instruction ( -- parser )
988 "OR-R" "OR" complex-instruction
989 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
991 : OR-(RR)-instruction ( -- parser )
992 "OR-(RR)" "OR" complex-instruction
993 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
995 : CP-N-instruction ( -- parser )
996 "CP-N" "CP" complex-instruction
998 just [ { } clone swap curry ] <@ ;
1000 : CP-R-instruction ( -- parser )
1001 "CP-R" "CP" complex-instruction
1002 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
1004 : CP-(RR)-instruction ( -- parser )
1005 "CP-(RR)" "CP" complex-instruction
1006 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
1008 : ADC-R,N-instruction ( -- parser )
1009 "ADC-R,N" "ADC" complex-instruction
1010 8-bit-registers sp <&>
1012 just [ first2 swap curry ] <@ ;
1014 : ADC-R,R-instruction ( -- parser )
1015 "ADC-R,R" "ADC" complex-instruction
1016 8-bit-registers sp <&>
1019 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1021 : ADC-R,(RR)-instruction ( -- parser )
1022 "ADC-R,(RR)" "ADC" complex-instruction
1023 8-bit-registers sp <&>
1025 16-bit-registers indirect <&>
1026 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1028 : SBC-R,N-instruction ( -- parser )
1029 "SBC-R,N" "SBC" complex-instruction
1030 8-bit-registers sp <&>
1032 just [ first2 swap curry ] <@ ;
1034 : SBC-R,R-instruction ( -- parser )
1035 "SBC-R,R" "SBC" complex-instruction
1036 8-bit-registers sp <&>
1039 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1041 : SBC-R,(RR)-instruction ( -- parser )
1042 "SBC-R,(RR)" "SBC" complex-instruction
1043 8-bit-registers sp <&>
1045 16-bit-registers indirect <&>
1046 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1048 : SUB-R-instruction ( -- parser )
1049 "SUB-R" "SUB" complex-instruction
1050 8-bit-registers sp <&>
1051 just [ first2 swap curry ] <@ ;
1053 : SUB-(RR)-instruction ( -- parser )
1054 "SUB-(RR)" "SUB" complex-instruction
1055 16-bit-registers indirect sp <&>
1056 just [ first2 swap curry ] <@ ;
1058 : SUB-N-instruction ( -- parser )
1059 "SUB-N" "SUB" complex-instruction
1061 just [ { } clone swap curry ] <@ ;
1063 : ADD-R,N-instruction ( -- parser )
1064 "ADD-R,N" "ADD" complex-instruction
1065 8-bit-registers sp <&>
1067 just [ first2 swap curry ] <@ ;
1069 : ADD-R,R-instruction ( -- parser )
1070 "ADD-R,R" "ADD" complex-instruction
1071 8-bit-registers sp <&>
1074 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1076 : ADD-RR,RR-instruction ( -- parser )
1077 "ADD-RR,RR" "ADD" complex-instruction
1078 16-bit-registers sp <&>
1080 16-bit-registers <&>
1081 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1083 : ADD-R,(RR)-instruction ( -- parser )
1084 "ADD-R,(RR)" "ADD" complex-instruction
1085 8-bit-registers sp <&>
1087 16-bit-registers indirect <&>
1088 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1090 : LD-RR,NN-instruction ( -- parser )
1092 "LD-RR,NN" "LD" complex-instruction
1093 16-bit-registers sp <&>
1095 just [ first2 swap curry ] <@ ;
1097 : LD-R,N-instruction ( -- parser )
1099 "LD-R,N" "LD" complex-instruction
1100 8-bit-registers sp <&>
1102 just [ first2 swap curry ] <@ ;
1104 : LD-(RR),N-instruction ( -- parser )
1105 "LD-(RR),N" "LD" complex-instruction
1106 16-bit-registers indirect sp <&>
1108 just [ first2 swap curry ] <@ ;
1110 : LD-(RR),R-instruction ( -- parser )
1112 "LD-(RR),R" "LD" complex-instruction
1113 16-bit-registers indirect sp <&>
1116 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1118 : LD-R,R-instruction ( -- parser )
1119 "LD-R,R" "LD" complex-instruction
1120 8-bit-registers sp <&>
1123 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1125 : LD-RR,RR-instruction ( -- parser )
1126 "LD-RR,RR" "LD" complex-instruction
1127 16-bit-registers sp <&>
1129 16-bit-registers <&>
1130 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1132 : LD-R,(RR)-instruction ( -- parser )
1133 "LD-R,(RR)" "LD" complex-instruction
1134 8-bit-registers sp <&>
1136 16-bit-registers indirect <&>
1137 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1139 : LD-(NN),RR-instruction ( -- parser )
1140 "LD-(NN),RR" "LD" complex-instruction
1141 "nn" token indirect sp <&
1143 16-bit-registers <&>
1144 just [ first2 swap curry ] <@ ;
1146 : LD-(NN),R-instruction ( -- parser )
1147 "LD-(NN),R" "LD" complex-instruction
1148 "nn" token indirect sp <&
1151 just [ first2 swap curry ] <@ ;
1153 : LD-RR,(NN)-instruction ( -- parser )
1154 "LD-RR,(NN)" "LD" complex-instruction
1155 16-bit-registers sp <&>
1157 "nn" token indirect <&
1158 just [ first2 swap curry ] <@ ;
1160 : LD-R,(NN)-instruction ( -- parser )
1161 "LD-R,(NN)" "LD" complex-instruction
1162 8-bit-registers sp <&>
1164 "nn" token indirect <&
1165 just [ first2 swap curry ] <@ ;
1167 : OUT-(N),R-instruction ( -- parser )
1168 "OUT-(N),R" "OUT" complex-instruction
1169 "n" token indirect sp <&
1172 just [ first2 swap curry ] <@ ;
1174 : IN-R,(N)-instruction ( -- parser )
1175 "IN-R,(N)" "IN" complex-instruction
1176 8-bit-registers sp <&>
1178 "n" token indirect <&
1179 just [ first2 swap curry ] <@ ;
1181 : EX-(RR),RR-instruction ( -- parser )
1182 "EX-(RR),RR" "EX" complex-instruction
1183 16-bit-registers indirect sp <&>
1185 16-bit-registers <&>
1186 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1188 : EX-RR,RR-instruction ( -- parser )
1189 "EX-RR,RR" "EX" complex-instruction
1190 16-bit-registers sp <&>
1192 16-bit-registers <&>
1193 just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
1195 : 8080-generator-parser ( -- parser )
1197 RST-0-instruction <|>
1198 RST-8-instruction <|>
1199 RST-10H-instruction <|>
1200 RST-18H-instruction <|>
1201 RST-20H-instruction <|>
1202 RST-28H-instruction <|>
1203 RST-30H-instruction <|>
1204 RST-38H-instruction <|>
1205 JP-F|FF,NN-instruction <|>
1206 JP-NN-instruction <|>
1207 JP-(RR)-instruction <|>
1208 CALL-F|FF,NN-instruction <|>
1209 CALL-NN-instruction <|>
1216 RLCA-instruction <|>
1217 RRCA-instruction <|>
1218 HALT-instruction <|>
1221 AND-N-instruction <|>
1222 AND-R-instruction <|>
1223 AND-(RR)-instruction <|>
1224 XOR-N-instruction <|>
1225 XOR-R-instruction <|>
1226 XOR-(RR)-instruction <|>
1227 OR-N-instruction <|>
1228 OR-R-instruction <|>
1229 OR-(RR)-instruction <|>
1230 CP-N-instruction <|>
1231 CP-R-instruction <|>
1232 CP-(RR)-instruction <|>
1233 DEC-RR-instruction <|>
1234 DEC-R-instruction <|>
1235 DEC-(RR)-instruction <|>
1236 POP-RR-instruction <|>
1237 PUSH-RR-instruction <|>
1238 INC-RR-instruction <|>
1239 INC-R-instruction <|>
1240 INC-(RR)-instruction <|>
1241 LD-RR,NN-instruction <|>
1242 LD-R,N-instruction <|>
1243 LD-R,R-instruction <|>
1244 LD-RR,RR-instruction <|>
1245 LD-(RR),N-instruction <|>
1246 LD-(RR),R-instruction <|>
1247 LD-R,(RR)-instruction <|>
1248 LD-(NN),RR-instruction <|>
1249 LD-(NN),R-instruction <|>
1250 LD-RR,(NN)-instruction <|>
1251 LD-R,(NN)-instruction <|>
1252 ADC-R,N-instruction <|>
1253 ADC-R,R-instruction <|>
1254 ADC-R,(RR)-instruction <|>
1255 ADD-R,N-instruction <|>
1256 ADD-R,R-instruction <|>
1257 ADD-RR,RR-instruction <|>
1258 ADD-R,(RR)-instruction <|>
1259 SBC-R,N-instruction <|>
1260 SBC-R,R-instruction <|>
1261 SBC-R,(RR)-instruction <|>
1262 SUB-R-instruction <|>
1263 SUB-(RR)-instruction <|>
1264 SUB-N-instruction <|>
1265 RET-F|FF-instruction <|>
1266 RET-NN-instruction <|>
1267 OUT-(N),R-instruction <|>
1268 IN-R,(N)-instruction <|>
1269 EX-(RR),RR-instruction <|>
1270 EX-RR,RR-instruction <|>
1273 : instruction-quotations ( string -- emulate-quot )
1274 #! Given an instruction string, return the emulation quotation for
1275 #! it. This will later be expanded to produce the disassembly and
1276 #! assembly quotations.
1277 8080-generator-parser some parse call ;
1279 SYMBOL: last-instruction
1282 : parse-instructions ( list -- emulate-quot )
1283 #! Process the list of strings, which should make
1284 #! up an 8080 instruction, and output a quotation
1285 #! that would implement that instruction.
1286 dup " " join instruction-quotations
1287 >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
1288 r> (( cpu -- )) define-declared ;
1290 : INSTRUCTION: ";" parse-tokens parse-instructions ; parsing
1293 #! Set the number of cycles for the last instruction that was defined.
1294 scan string>number last-opcode global at instruction-cycles set-nth ; parsing
1297 #! Set the opcode number for the last instruction that was defined.
1298 last-instruction global at 1quotation scan 16 base>
1299 dup last-opcode global set-at set-instruction ; parsing