| blob | adb06e68f09c8e366488f194c8eacd9f75e88ded |
1 ! Copyright (C) 2006 Chris Double.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators fry io
4 io.encodings.binary io.files io.pathnames kernel lexer make math
5 math.parser namespaces parser peg peg.ebnf peg.parsers
6 quotations sequences sequences.deep words multiline ;
7 IN: cpu.8080.emulator
9 TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles
10 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
18 3drop ;
20 M: cpu read-port
21 ! Read a byte from the hardware port. 'port' should
22 ! be an 8-bit value.
23 2drop 0 ;
25 M: cpu write-port
26 ! Write a byte to the hardware port, where 'port' is
27 ! an 8-bit value.
28 3drop ;
30 CONSTANT: carry-flag 0x01
31 CONSTANT: parity-flag 0x04
32 CONSTANT: half-carry-flag 0x10
33 CONSTANT: interrupt-flag 0x20
34 CONSTANT: zero-flag 0x40
35 CONSTANT: sign-flag 0x80
37 : >word< ( word -- byte byte )
38 ! Explode a word into its two 8 bit values.
39 dup 0xFF bitand swap -8 shift 0xFF bitand swap ;
41 : af>> ( cpu -- word )
42 ! Return the 16-bit pseudo register AF.
43 [ a>> 8 shift ] keep f>> bitor ;
45 : af<< ( value cpu -- )
46 ! Set the value of the 16-bit pseudo register AF
47 [ >word< ] dip swap >>f swap >>a drop ;
49 : bc>> ( cpu -- word )
50 ! Return the 16-bit pseudo register BC.
51 [ b>> 8 shift ] keep c>> bitor ;
53 : bc<< ( value cpu -- )
54 ! Set the value of the 16-bit pseudo register BC
55 [ >word< ] dip swap >>c swap >>b drop ;
57 : de>> ( cpu -- word )
58 ! Return the 16-bit pseudo register DE.
59 [ d>> 8 shift ] keep e>> bitor ;
61 : de<< ( value cpu -- )
62 ! Set the value of the 16-bit pseudo register DE
63 [ >word< ] dip swap >>e swap >>d drop ;
65 : hl>> ( cpu -- word )
66 ! Return the 16-bit pseudo register HL.
67 [ h>> 8 shift ] keep l>> bitor ;
69 : hl<< ( value cpu -- )
70 ! Set the value of the 16-bit pseudo register HL
71 [ >word< ] dip swap >>l swap >>h drop ;
73 : flag-set? ( flag cpu -- bool )
74 f>> bitand 0 = not ;
76 : flag-clear? ( flag cpu -- bool )
77 f>> bitand 0 = ;
79 : flag-nz? ( cpu -- bool )
80 ! Test flag status
81 f>> zero-flag bitand 0 = ;
83 : flag-z? ( cpu -- bool )
84 ! Test flag status
85 f>> zero-flag bitand 0 = not ;
87 : flag-nc? ( cpu -- bool )
88 ! Test flag status
89 f>> carry-flag bitand 0 = ;
91 : flag-c? ( cpu -- bool )
92 ! Test flag status
93 f>> carry-flag bitand 0 = not ;
95 : flag-po? ( cpu -- bool )
96 ! Test flag status
97 f>> parity-flag bitand 0 = ;
99 : flag-pe? ( cpu -- bool )
100 ! Test flag status
101 f>> parity-flag bitand 0 = not ;
103 : flag-p? ( cpu -- bool )
104 ! Test flag status
105 f>> sign-flag bitand 0 = ;
107 : flag-m? ( cpu -- bool )
108 ! Test flag status
109 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.
115 over 0xFFFF <= [
116 ram>> nth
117 ] [
118 2drop 0xFF
119 ] if ;
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 [ 1 + ] dip read-byte 8 shift bitor ;
127 : next-byte ( cpu -- byte )
128 ! Return the value of the byte at PC, and increment PC.
129 {
130 [ pc>> ]
131 [ read-byte ]
132 [ pc>> 1 + ]
133 [ pc<< ]
134 } cleave ;
136 : next-word ( cpu -- word )
137 ! Return the value of the word at PC, and increment PC.
138 [ pc>> ] keep
139 [ read-word ] keep
140 [ pc>> 2 + ] keep
141 pc<< ;
144 : write-byte ( value addr cpu -- )
145 ! Write a byte to the specified memory address.
146 over dup 0x2000 < swap 0xFFFF > or [
147 3drop
148 ] [
149 3dup ram>> set-nth
150 update-video
151 ] if ;
154 : write-word ( value addr cpu -- )
155 ! Write a 16-bit word to the specified memory address.
156 [ >word< ] 2dip [ write-byte ] 2keep [ 1 + ] dip write-byte ;
158 : cpu-a-bitand ( quot cpu -- )
159 ! A &= quot call
160 [ a>> swap call bitand ] keep a<< ; inline
162 : cpu-a-bitor ( quot cpu -- )
163 ! A |= quot call
164 [ a>> swap call bitor ] keep a<< ; inline
166 : cpu-a-bitxor ( quot cpu -- )
167 ! A ^= quot call
168 [ a>> swap call bitxor ] keep a<< ; inline
170 : cpu-a-bitxor= ( value cpu -- )
171 ! cpu-a ^= value
172 [ a>> bitxor ] keep a<< ;
174 : cpu-f-bitand ( quot cpu -- )
175 ! F &= quot call
176 [ f>> swap call bitand ] keep f<< ; inline
178 : cpu-f-bitor ( quot cpu -- )
179 ! F |= quot call
180 [ f>> swap call bitor ] keep f<< ; inline
182 : cpu-f-bitxor ( quot cpu -- )
183 ! F |= quot call
184 [ f>> swap call bitxor ] keep f<< ; inline
186 : cpu-f-bitor= ( value cpu -- )
187 ! cpu-f |= value
188 [ f>> bitor ] keep f<< ;
190 : cpu-f-bitand= ( value cpu -- )
191 ! cpu-f &= value
192 [ f>> bitand ] keep f<< ;
194 : cpu-f-bitxor= ( value cpu -- )
195 ! cpu-f ^= value
196 [ f>> bitxor ] keep f<< ;
198 : set-flag ( cpu flag -- )
199 swap cpu-f-bitor= ;
201 : clear-flag ( cpu flag -- )
202 bitnot 0xFF bitand swap cpu-f-bitand= ;
204 : update-zero-flag ( result cpu -- )
205 ! If the result of an instruction has the value 0, this
206 ! flag is set, otherwise it is reset.
207 swap 0xFF bitand 0 =
208 [ zero-flag set-flag ]
209 [ zero-flag clear-flag ] if ;
211 : update-sign-flag ( result cpu -- )
212 ! If the most significant bit of the result
213 ! has the value 1 then the flag is set, otherwise
214 ! it is reset.
215 swap 0x80 bitand 0 =
216 [ sign-flag clear-flag ]
217 [ sign-flag set-flag ] if ;
219 : update-parity-flag ( result cpu -- )
220 ! If the modulo 2 sum of the bits of the result
221 ! is 0, (ie. if the result has even parity) this flag
222 ! is set, otherwise it is reset.
223 swap 0xFF bitand 2 mod 0 =
224 [ parity-flag set-flag ]
225 [ parity-flag clear-flag ] if ;
227 : update-carry-flag ( result cpu -- )
228 ! If the instruction resulted in a carry (from addition)
229 ! or a borrow (from subtraction or a comparison) out of the
230 ! higher order bit, this flag is set, otherwise it is reset.
231 swap dup 0x100 >= swap 0 < or
232 [ carry-flag set-flag ]
233 [ carry-flag clear-flag ] if ;
235 : update-half-carry-flag ( original change-by result cpu -- )
236 ! If the instruction caused a carry out of bit 3 and into bit 4 of the
237 ! resulting value, the half carry flag is set, otherwise it is reset.
238 ! The 'original' is the original value of the register being changed.
239 ! 'change-by' is the amount it is being added or decremented by.
240 ! 'result' is the result of that change.
241 [ bitxor bitxor 0x10 bitand 0 = not ] dip swap
242 [ half-carry-flag set-flag ]
243 [ half-carry-flag clear-flag ] if ;
245 : update-flags ( result cpu -- )
246 {
247 [ update-carry-flag ]
248 [ update-parity-flag ]
249 [ update-sign-flag ]
250 [ update-zero-flag ]
251 } 2cleave ;
253 : update-flags-no-carry ( result cpu -- )
254 [ update-parity-flag ]
255 [ update-sign-flag ]
256 [ update-zero-flag ] 2tri ;
258 : add-byte ( lhs rhs cpu -- result )
259 ! Add rhs to lhs
260 [ 2dup + ] dip
261 [ update-flags ] 2keep
262 [ update-half-carry-flag ] 2keep
263 drop 0xFF bitand ;
265 : add-carry ( change-by result cpu -- change-by result )
266 ! Add the effect of the carry flag to the result
267 flag-c? [ 1 + [ 1 + ] dip ] when ;
269 : add-byte-with-carry ( lhs rhs cpu -- result )
270 ! Add rhs to lhs plus carry.
271 [ 2dup + ] dip
272 [ add-carry ] keep
273 [ update-flags ] 2keep
274 [ update-half-carry-flag ] 2keep
275 drop 0xFF bitand ;
277 : sub-carry ( change-by result cpu -- change-by result )
278 ! Subtract the effect of the carry flag from the result
279 flag-c? [ 1 - [ 1 - ] dip ] when ;
281 : sub-byte ( lhs rhs cpu -- result )
282 ! Subtract rhs from lhs
283 [ 2dup - ] dip
284 [ update-flags ] 2keep
285 [ update-half-carry-flag ] 2keep
286 drop 0xFF bitand ;
288 : sub-byte-with-carry ( lhs rhs cpu -- result )
289 ! Subtract rhs from lhs and take carry into account
290 [ 2dup - ] dip
291 [ sub-carry ] keep
292 [ update-flags ] 2keep
293 [ update-half-carry-flag ] 2keep
294 drop 0xFF bitand ;
296 : inc-byte ( byte cpu -- result )
297 ! Increment byte by one. Note that carry flag is not affected
298 ! by this operation.
299 [ 1 2dup + ] dip
300 [ update-flags-no-carry ] 2keep
301 [ update-half-carry-flag ] 2keep
302 drop 0xFF bitand ;
304 : dec-byte ( byte cpu -- result )
305 ! Decrement byte by one. Note that carry flag is not affected
306 ! by this operation.
307 [ 1 2dup - ] dip
308 [ update-flags-no-carry ] 2keep
309 [ update-half-carry-flag ] 2keep
310 drop 0xFF bitand ;
312 : inc-word ( w cpu -- w )
313 ! Increment word by one. Note that no flags are modified.
314 drop 1 + 0xFFFF bitand ;
316 : dec-word ( w cpu -- w )
317 ! Decrement word by one. Note that no flags are modified.
318 drop 1 - 0xFFFF bitand ;
320 : add-word ( lhs rhs cpu -- result )
321 ! Add rhs to lhs. Note that only the carry flag is modified
322 ! and only if there is a carry out of the double precision add.
323 [ + ] dip over 0xFFFF > [ carry-flag set-flag ] [ drop ] if 0xFFFF bitand ;
325 : bit3or ( lhs rhs -- 0|1 )
326 ! bitor bit 3 of the two numbers on the stack
327 [ 0b00001000 bitand -3 shift ] bi@ bitor ;
329 : and-byte ( lhs rhs cpu -- result )
330 ! Logically and rhs to lhs. The carry flag is cleared and
331 ! the half carry is set to the ORing of bits 3 of the operands.
332 [ drop bit3or ] 3keep ! bit3or lhs rhs cpu
333 [ bitand ] dip [ update-flags ] 2keep
334 [ carry-flag clear-flag ] keep
335 rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if
336 0xFF bitand ;
338 : xor-byte ( lhs rhs cpu -- result )
339 ! Logically xor rhs to lhs. The carry and half-carry flags are cleared.
340 [ bitxor ] dip [ update-flags ] 2keep
341 half-carry-flag carry-flag bitor clear-flag
342 0xFF bitand ;
344 : or-byte ( lhs rhs cpu -- result )
345 ! Logically or rhs to lhs. The carry and half-carry flags are cleared.
346 [ bitor ] dip [ update-flags ] 2keep
347 half-carry-flag carry-flag bitor clear-flag
348 0xFF bitand ;
350 : decrement-sp ( n cpu -- )
351 ! Decrement the stackpointer by n.
352 [ sp>> swap - ] keep sp<< ;
354 : save-pc ( cpu -- )
355 ! Save the value of the PC on the stack.
356 [ pc>> ] [ sp>> ] [ write-word ] tri ;
358 : push-pc ( cpu -- )
359 ! Push the value of the PC on the stack.
360 [ 2 swap decrement-sp ] [ save-pc ] bi ;
362 : pop-pc ( cpu -- pc )
363 ! Pop the value of the PC off the stack.
364 [ sp>> ] [ read-word ] [ -2 swap decrement-sp ] tri ;
366 : push-sp ( value cpu -- )
367 [ 2 swap decrement-sp ] [ sp>> ] [ write-word ] tri ;
369 : pop-sp ( cpu -- value )
370 [ sp>> ] [ read-word ] [ -2 swap decrement-sp ] tri ;
372 : call-sub ( addr cpu -- )
373 ! Call the address as a subroutine.
374 dup push-pc
375 [ 0xFFFF bitand ] dip pc<< ;
377 : ret-from-sub ( cpu -- )
378 [ pop-pc ] keep pc<< ;
380 : interrupt ( number cpu -- )
381 ! Perform a hardware interrupt
382 ! "***Interrupt: " write over >hex print
383 dup f>> interrupt-flag bitand 0 = not [
384 dup push-pc
385 pc<<
386 ] [
387 2drop
388 ] if ;
390 : inc-cycles ( n cpu -- )
391 ! Increment the number of cpu cycles
392 [ cycles>> + ] keep cycles<< ;
394 : instruction-cycles ( -- vector )
395 ! Return a 256 element vector containing the cycles for
396 ! each opcode in the 8080 instruction set.
397 \ instruction-cycles get-global [
398 256 f <array> \ instruction-cycles set-global
399 ] unless
400 \ instruction-cycles get-global ;
402 : not-implemented ( cpu -- )
403 drop ;
405 : instructions ( -- vector )
406 ! Return a 256 element vector containing the emulation words for
407 ! each opcode in the 8080 instruction set.
408 \ instructions get-global [
409 256 [ not-implemented ] <array> \ instructions set-global
410 ] unless
411 \ instructions get-global ;
413 : set-instruction ( quot n -- )
414 instructions set-nth ;
416 M: cpu reset
417 ! Reset the CPU to its poweron state
418 0 >>b
419 0 >>c
420 0 >>d
421 0 >>e
422 0 >>h
423 0 >>l
424 0 >>a
425 0 >>f
426 0 >>pc
427 0xF000 >>sp
428 0xFFFF 0 <array> >>ram
429 f >>halted?
430 0x10 >>last-interrupt
431 0 >>cycles
432 drop ;
434 : <cpu> ( -- cpu ) cpu new dup reset ;
436 : (load-rom) ( n ram -- )
437 read1 [ ! n ram ch
438 -rot [ set-nth ] 2keep [ 1 + ] dip (load-rom)
439 ] [
440 2drop
441 ] if* ;
443 ! Reads the ROM from stdin and stores it in ROM from
444 ! offset n.
445 : load-rom ( filename cpu -- )
446 ! Load the contents of the file into ROM.
447 ! (address 0x0000-0x1FFF).
448 ram>> swap binary [
449 0 swap (load-rom)
450 ] with-file-reader ;
452 SYMBOL: rom-root
454 : rom-dir ( -- string )
455 rom-root get [
456 home "roms" append-path dup exists? [ drop f ] unless
457 ] unless* ;
459 : load-rom* ( seq cpu -- )
460 ! 'seq' is an array of arrays. Each array contains
461 ! an address and filename of a ROM file. The ROM
462 ! file will be loaded at the specified address. This
463 ! file path shoul dbe relative to the '/roms' resource path.
464 rom-dir [
465 ram>> [
466 swap first2 rom-dir prepend-path binary [
467 swap (load-rom)
468 ] with-file-reader
469 ] curry each
470 ] [
471 !
472 ! the ROM files.
473 "Set 'rom-root' to the path containing the root of the 8080 ROM files." throw
474 ] if ;
476 : read-instruction ( cpu -- word )
477 ! Read the next instruction from the cpu's program
478 ! counter, and increment the program counter.
479 [ pc>> ] keep ! pc cpu
480 [ over 1 + swap pc<< ] keep
481 read-byte ;
483 ERROR: undefined-8080-opcode n ;
485 : get-cycles ( n -- opcode )
486 ! Returns the cycles for the given instruction value.
487 ! If the opcode is not defined throw an error.
488 dup instruction-cycles nth [
489 nip
490 ] [
491 undefined-8080-opcode
492 ] if* ;
494 : process-interrupts ( cpu -- )
495 ! Process any hardware interrupts
496 [ cycles>> ] keep
497 over 16667 < [
498 2drop
499 ] [
500 [ [ 16667 - ] dip cycles<< ] keep
501 dup last-interrupt>> 0x10 = [
502 0x08 >>last-interrupt 0x08 swap interrupt
503 ] [
504 0x10 >>last-interrupt 0x10 swap interrupt
505 ] if
506 ] if ;
508 : peek-instruction ( cpu -- word )
509 ! Return the next instruction from the cpu's program
510 ! counter, but don't increment the counter.
511 [ pc>> ] keep read-byte instructions nth first ;
513 : cpu. ( cpu -- )
514 {
515 [ " PC: " write pc>> >hex 4 CHAR: \s pad-head write ]
516 [ " B: " write b>> >hex 2 CHAR: \s pad-head write ]
517 [ " C: " write c>> >hex 2 CHAR: \s pad-head write ]
518 [ " D: " write d>> >hex 2 CHAR: \s pad-head write ]
519 [ " E: " write e>> >hex 2 CHAR: \s pad-head write ]
520 [ " F: " write f>> >hex 2 CHAR: \s pad-head write ]
521 [ " H: " write h>> >hex 2 CHAR: \s pad-head write ]
522 [ " L: " write l>> >hex 2 CHAR: \s pad-head write ]
523 [ " A: " write a>> >hex 2 CHAR: \s pad-head write ]
524 [ " SP: " write sp>> >hex 4 CHAR: \s pad-head write ]
525 [ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ]
526 [ bl peek-instruction name>> write bl ]
527 [ nl drop ]
528 } cleave ;
530 : cpu*. ( cpu -- )
531 {
532 [ " PC: " write pc>> >hex 4 CHAR: \s pad-head write ]
533 [ " B: " write b>> >hex 2 CHAR: \s pad-head write ]
534 [ " C: " write c>> >hex 2 CHAR: \s pad-head write ]
535 [ " D: " write d>> >hex 2 CHAR: \s pad-head write ]
536 [ " E: " write e>> >hex 2 CHAR: \s pad-head write ]
537 [ " F: " write f>> >hex 2 CHAR: \s pad-head write ]
538 [ " H: " write h>> >hex 2 CHAR: \s pad-head write ]
539 [ " L: " write l>> >hex 2 CHAR: \s pad-head write ]
540 [ " A: " write a>> >hex 2 CHAR: \s pad-head write ]
541 [ " SP: " write sp>> >hex 4 CHAR: \s pad-head write ]
542 [ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ]
543 [ nl drop ]
544 } cleave ;
546 : register-lookup ( string -- vector )
547 ! Given a string containing a register name, return a vector
548 ! where the 1st item is the getter and the 2nd is the setter
549 ! for that register.
550 H{
551 { "A" { a>> a<< } }
552 { "B" { b>> b<< } }
553 { "C" { c>> c<< } }
554 { "D" { d>> d<< } }
555 { "E" { e>> e<< } }
556 { "H" { h>> h<< } }
557 { "L" { l>> l<< } }
558 { "AF" { af>> af<< } }
559 { "BC" { bc>> bc<< } }
560 { "DE" { de>> de<< } }
561 { "HL" { hl>> hl<< } }
562 { "SP" { sp>> sp<< } }
563 } at ;
566 : flag-lookup ( string -- vector )
567 ! Given a string containing a flag name, return a vector
568 ! where the 1st item is a word that tests that flag.
569 H{
570 { "NZ" { flag-nz? } }
571 { "NC" { flag-nc? } }
572 { "PO" { flag-po? } }
573 { "PE" { flag-pe? } }
574 { "Z" { flag-z? } }
575 { "C" { flag-c? } }
576 { "P" { flag-p? } }
577 { "M" { flag-m? } }
578 } at ;
580 SYMBOLS: $1 $2 $3 $4 ;
582 : replace-patterns ( vector tree -- tree )
583 [
584 {
585 { $1 [ first ] }
586 { $2 [ second ] }
587 { $3 [ third ] }
588 { $4 [ fourth ] }
589 [ nip ]
590 } case
591 ] with deep-map ;
593 : (emulate-RST) ( n cpu -- )
594 ! RST nn
595 [ sp>> 2 - dup ] keep ! sp sp cpu
596 [ sp<< ] keep ! sp cpu
597 [ pc>> ] keep ! sp pc cpu
598 swapd [ write-word ] keep ! cpu
599 [ 8 * ] dip pc<< ;
601 : (emulate-CALL) ( cpu -- )
602 ! 205 - CALL nn
603 [ next-word 0xFFFF bitand ] keep ! addr cpu
604 [ sp>> 2 - dup ] keep ! addr sp sp cpu
605 [ sp<< ] keep ! addr sp cpu
606 [ pc>> ] keep ! addr sp pc cpu
607 swapd [ write-word ] keep ! addr cpu
608 pc<< ;
610 : (emulate-RLCA) ( cpu -- )
611 ! The content of the accumulator is rotated left
612 ! one position. The low order bit and the carry flag
613 ! are both set to the value shifd out of the high
614 ! order bit position. Only the carry flag is affected.
615 [ a>> -7 shift ] keep
616 over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
617 [ a>> 1 shift 0xFF bitand ] keep
618 [ bitor ] dip a<< ;
620 : (emulate-RRCA) ( cpu -- )
621 ! The content of the accumulator is rotated right
622 ! one position. The high order bit and the carry flag
623 ! are both set to the value shifd out of the low
624 ! order bit position. Only the carry flag is affected.
625 [ a>> 1 bitand 7 shift ] keep
626 over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
627 [ a>> 254 bitand -1 shift ] keep
628 [ bitor ] dip a<< ;
630 : (emulate-RLA) ( cpu -- )
631 ! The content of the accumulator is rotated left
632 ! one position through the carry flag. The low
633 ! order bit is set equal to the carry flag and
634 ! the carry flag is set to the value shifd out
635 ! of the high order bit. Only the carry flag is
636 ! affected.
637 [ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
638 [ a>> 127 bitand 7 shift ] keep
639 dup a>> 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
640 [ bitor ] dip a<< ;
642 : (emulate-RRA) ( cpu -- )
643 ! The content of the accumulator is rotated right
644 ! one position through the carry flag. The high order
645 ! bit is set to the carry flag and the carry flag is
646 ! set to the value shifd out of the low order bit.
647 ! Only the carry flag is affected.
648 [ carry-flag swap flag-set? [ 0b10000000 ] [ 0 ] if ] keep
649 [ a>> 254 bitand -1 shift ] keep
650 dup a>> 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
651 [ bitor ] dip a<< ;
653 : (emulate-CPL) ( cpu -- )
654 ! The contents of the accumulator are complemented
655 ! (zero bits become one, one bits becomes zero).
656 ! No flags are affected.
657 0xFF swap cpu-a-bitxor= ;
659 : (emulate-DAA) ( cpu -- )
660 ! The eight bit number in the accumulator is
661 ! adjusted to form two four-bit binary-coded-decimal
662 ! digits.
663 [
664 dup half-carry-flag swap flag-set? swap
665 a>> 0b1111 bitand 9 > or [ 6 ] [ 0 ] if
666 ] keep
667 [ a>> + ] keep
668 [ update-flags ] 2keep
669 [ swap 0xFF bitand swap a<< ] keep
670 [
671 dup carry-flag swap flag-set? swap
672 a>> -4 shift 0b1111 bitand 9 > or [ 96 ] [ 0 ] if
673 ] keep
674 [ a>> + ] keep
675 [ update-flags ] 2keep
676 swap 0xFF bitand swap a<< ;
678 : patterns ( -- hashtable )
679 ! table of code quotation patterns for each type of instruction.
680 H{
681 { "NOP" [ drop ] }
682 { "RET-NN" [ ret-from-sub ] }
683 { "RST-0" [ 0 swap (emulate-RST) ] }
684 { "RST-8" [ 8 swap (emulate-RST) ] }
685 { "RST-10H" [ 0x10 swap (emulate-RST) ] }
686 { "RST-18H" [ 0x18 swap (emulate-RST) ] }
687 { "RST-20H" [ 0x20 swap (emulate-RST) ] }
688 { "RST-28H" [ 0x28 swap (emulate-RST) ] }
689 { "RST-30H" [ 0x30 swap (emulate-RST) ] }
690 { "RST-38H" [ 0x38 swap (emulate-RST) ] }
691 { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
692 { "CP-N" [ [ a>> ] keep [ next-byte ] keep sub-byte drop ] }
693 { "CP-R" [ [ a>> ] keep [ $1 ] keep sub-byte drop ] }
694 { "CP-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] }
695 { "OR-N" [ [ a>> ] keep [ next-byte ] keep [ or-byte ] keep a<< ] }
696 { "OR-R" [ [ a>> ] keep [ $1 ] keep [ or-byte ] keep a<< ] }
697 { "OR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep a<< ] }
698 { "XOR-N" [ [ a>> ] keep [ next-byte ] keep [ xor-byte ] keep a<< ] }
699 { "XOR-R" [ [ a>> ] keep [ $1 ] keep [ xor-byte ] keep a<< ] }
700 { "XOR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep a<< ] }
701 { "AND-N" [ [ a>> ] keep [ next-byte ] keep [ and-byte ] keep a<< ] }
702 { "AND-R" [ [ a>> ] keep [ $1 ] keep [ and-byte ] keep a<< ] }
703 { "AND-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep a<< ] }
704 { "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] }
705 { "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] }
706 { "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] }
707 { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] }
708 { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] }
709 { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] }
710 { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] }
711 { "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
712 { "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] }
713 { "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
714 { "SUB-R" [ [ a>> ] keep [ $1 ] keep [ sub-byte ] keep a<< ] }
715 { "SUB-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep a<< ] }
716 { "SUB-N" [ [ a>> ] keep [ next-byte ] keep [ sub-byte ] keep a<< ] }
717 { "CPL" [ (emulate-CPL) ] }
718 { "DAA" [ (emulate-DAA) ] }
719 { "RLA" [ (emulate-RLA) ] }
720 { "RRA" [ (emulate-RRA) ] }
721 { "CCF" [ carry-flag swap cpu-f-bitxor= ] }
722 { "SCF" [ carry-flag swap cpu-f-bitor= ] }
723 { "RLCA" [ (emulate-RLCA) ] }
724 { "RRCA" [ (emulate-RRCA) ] }
725 { "HALT" [ drop ] }
726 { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] }
727 { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] }
728 { "POP-RR" [ [ pop-sp ] keep $2 ] }
729 { "PUSH-RR" [ [ $1 ] keep push-sp ] }
730 { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] }
731 { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] }
732 { "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] }
733 { "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] }
734 { "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] }
735 { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] }
736 { "JP-NN" [ [ pc>> ] keep [ read-word ] keep pc<< ] }
737 { "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ pc<< ] keep [ cycles>> ] keep swap 5 + swap cycles<< ] [ [ pc>> 2 + ] keep pc<< ] if ] }
738 { "JP-(RR)" [ [ $1 ] keep pc<< ] }
739 { "CALL-NN" [ (emulate-CALL) ] }
740 { "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ pc>> 2 + ] keep pc<< ] if ] }
741 { "LD-RR,NN" [ [ next-word ] keep $2 ] }
742 { "LD-RR,RR" [ [ $3 ] keep $2 ] }
743 { "LD-R,N" [ [ next-byte ] keep $2 ] }
744 { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] }
745 { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] }
746 { "LD-R,R" [ [ $3 ] keep $2 ] }
747 { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] }
748 { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] }
749 { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] }
750 { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] }
751 { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] }
752 { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] }
753 { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep a<< ] }
754 { "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] }
755 { "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
756 } ;
758 EBNF-PARSER: 8-bit-registers
759 ! A parser for 8-bit registers. On a successfull parse the
760 ! parse tree contains a vector. The first item in the vector
761 ! is the getter word for that register with stack effect
762 ! ( cpu -- value ). The second item is the setter word with
763 ! stack effect ( value cpu -- ).
764 [=[
765 main=("A" | "B" | "C" | "D" | "E" | "H" | "L") => [[ register-lookup ]]
766 ]=]
768 EBNF-PARSER: all-flags
769 ! A parser for 16-bit flags.
770 [=[
771 main=("NZ" | "NC" | "PO" | "PE" | "Z" | "C" | "P" | "M") => [[ flag-lookup ]]
772 ]=]
774 EBNF-PARSER: 16-bit-registers
775 ! A parser for 16-bit registers. On a successfull parse the
776 ! parse tree contains a vector. The first item in the vector
777 ! is the getter word for that register with stack effect
778 ! ( cpu -- value ). The second item is the setter word with
779 ! stack effect ( value cpu -- ).
780 [=[
781 main=("AF" | "BC" | "DE" | "HL" | "SP") => [[ register-lookup ]]
782 ]=]
784 : all-registers ( -- parser )
785 ! Return a parser that can parse the format
786 ! for 8 bit or 16 bit registers.
787 [ 16-bit-registers , 8-bit-registers , ] choice* ;
789 : indirect ( parser -- parser )
790 ! Given a parser, return a parser which parses the original
791 ! wrapped in brackets, representing an indirect reference.
792 ! eg. BC -> (BC). The value of the original parser is left in
793 ! the parse tree.
794 "(" ")" surrounded-by ;
796 : generate-instruction ( vector string -- quot )
797 ! Generate the quotation for an instruction, given the instruction in
798 ! the 'string' and a vector containing the arguments for that instruction.
799 patterns at replace-patterns ;
801 : simple-instruction ( token -- parser )
802 ! Return a parser for then instruction identified by the token.
803 ! The parser return parses the token only and expects no additional
804 ! arguments to the instruction.
805 token [ '[ { } _ generate-instruction ] ] action ;
807 : complex-instruction ( type token -- parser )
808 ! Return a parser for an instruction identified by the token.
809 ! The instruction is expected to take additional arguments by
810 ! being combined with other parsers. Then 'type' is used for a lookup
811 ! in a pattern hashtable to return the instruction quotation pattern.
812 token swap [ nip '[ _ generate-instruction ] ] curry action ;
814 : no-params ( ast -- ast )
815 first { } swap curry ;
817 : one-param ( ast -- ast )
818 first2 swap curry ;
820 : two-params ( ast -- ast )
821 first3 append swap curry ;
823 : NOP-instruction ( -- parser )
824 "NOP" simple-instruction ;
826 : RET-NN-instruction ( -- parser )
827 [
828 "RET-NN" "RET" complex-instruction ,
829 "nn" token sp hide ,
830 ] seq* [ no-params ] action ;
832 : RST-0-instruction ( -- parser )
833 [
834 "RST-0" "RST" complex-instruction ,
835 "0" token sp hide ,
836 ] seq* [ no-params ] action ;
838 : RST-8-instruction ( -- parser )
839 [
840 "RST-8" "RST" complex-instruction ,
841 "8" token sp hide ,
842 ] seq* [ no-params ] action ;
844 : RST-10H-instruction ( -- parser )
845 [
846 "RST-10H" "RST" complex-instruction ,
847 "10H" token sp hide ,
848 ] seq* [ no-params ] action ;
850 : RST-18H-instruction ( -- parser )
851 [
852 "RST-18H" "RST" complex-instruction ,
853 "18H" token sp hide ,
854 ] seq* [ no-params ] action ;
856 : RST-20H-instruction ( -- parser )
857 [
858 "RST-20H" "RST" complex-instruction ,
859 "20H" token sp hide ,
860 ] seq* [ no-params ] action ;
862 : RST-28H-instruction ( -- parser )
863 [
864 "RST-28H" "RST" complex-instruction ,
865 "28H" token sp hide ,
866 ] seq* [ no-params ] action ;
868 : RST-30H-instruction ( -- parser )
869 [
870 "RST-30H" "RST" complex-instruction ,
871 "30H" token sp hide ,
872 ] seq* [ no-params ] action ;
874 : RST-38H-instruction ( -- parser )
875 [
876 "RST-38H" "RST" complex-instruction ,
877 "38H" token sp hide ,
878 ] seq* [ no-params ] action ;
880 : JP-NN-instruction ( -- parser )
881 [
882 "JP-NN" "JP" complex-instruction ,
883 "nn" token sp hide ,
884 ] seq* [ no-params ] action ;
886 : JP-F|FF,NN-instruction ( -- parser )
887 [
888 "JP-F|FF,NN" "JP" complex-instruction ,
889 all-flags sp ,
890 ",nn" token hide ,
891 ] seq* [ one-param ] action ;
893 : JP-(RR)-instruction ( -- parser )
894 [
895 "JP-(RR)" "JP" complex-instruction ,
896 16-bit-registers indirect sp ,
897 ] seq* [ one-param ] action ;
899 : CALL-NN-instruction ( -- parser )
900 [
901 "CALL-NN" "CALL" complex-instruction ,
902 "nn" token sp hide ,
903 ] seq* [ no-params ] action ;
905 : CALL-F|FF,NN-instruction ( -- parser )
906 [
907 "CALL-F|FF,NN" "CALL" complex-instruction ,
908 all-flags sp ,
909 ",nn" token hide ,
910 ] seq* [ one-param ] action ;
912 : RLCA-instruction ( -- parser )
913 "RLCA" simple-instruction ;
915 : RRCA-instruction ( -- parser )
916 "RRCA" simple-instruction ;
918 : HALT-instruction ( -- parser )
919 "HALT" simple-instruction ;
921 : DI-instruction ( -- parser )
922 "DI" simple-instruction ;
924 : EI-instruction ( -- parser )
925 "EI" simple-instruction ;
927 : CPL-instruction ( -- parser )
928 "CPL" simple-instruction ;
930 : CCF-instruction ( -- parser )
931 "CCF" simple-instruction ;
933 : SCF-instruction ( -- parser )
934 "SCF" simple-instruction ;
936 : DAA-instruction ( -- parser )
937 "DAA" simple-instruction ;
939 : RLA-instruction ( -- parser )
940 "RLA" simple-instruction ;
942 : RRA-instruction ( -- parser )
943 "RRA" simple-instruction ;
945 : DEC-R-instruction ( -- parser )
946 [
947 "DEC-R" "DEC" complex-instruction ,
948 8-bit-registers sp ,
949 ] seq* [ one-param ] action ;
951 : DEC-RR-instruction ( -- parser )
952 [
953 "DEC-RR" "DEC" complex-instruction ,
954 16-bit-registers sp ,
955 ] seq* [ one-param ] action ;
957 : DEC-(RR)-instruction ( -- parser )
958 [
959 "DEC-(RR)" "DEC" complex-instruction ,
960 16-bit-registers indirect sp ,
961 ] seq* [ one-param ] action ;
963 : POP-RR-instruction ( -- parser )
964 [
965 "POP-RR" "POP" complex-instruction ,
966 all-registers sp ,
967 ] seq* [ one-param ] action ;
969 : PUSH-RR-instruction ( -- parser )
970 [
971 "PUSH-RR" "PUSH" complex-instruction ,
972 all-registers sp ,
973 ] seq* [ one-param ] action ;
975 : INC-R-instruction ( -- parser )
976 [
977 "INC-R" "INC" complex-instruction ,
978 8-bit-registers sp ,
979 ] seq* [ one-param ] action ;
981 : INC-RR-instruction ( -- parser )
982 [
983 "INC-RR" "INC" complex-instruction ,
984 16-bit-registers sp ,
985 ] seq* [ one-param ] action ;
987 : INC-(RR)-instruction ( -- parser )
988 [
989 "INC-(RR)" "INC" complex-instruction ,
990 all-registers indirect sp ,
991 ] seq* [ one-param ] action ;
993 : RET-F|FF-instruction ( -- parser )
994 [
995 "RET-F|FF" "RET" complex-instruction ,
996 all-flags sp ,
997 ] seq* [ one-param ] action ;
999 : AND-N-instruction ( -- parser )
1000 [
1001 "AND-N" "AND" complex-instruction ,
1002 "n" token sp hide ,
1003 ] seq* [ no-params ] action ;
1005 : AND-R-instruction ( -- parser )
1006 [
1007 "AND-R" "AND" complex-instruction ,
1008 8-bit-registers sp ,
1009 ] seq* [ one-param ] action ;
1011 : AND-(RR)-instruction ( -- parser )
1012 [
1013 "AND-(RR)" "AND" complex-instruction ,
1014 16-bit-registers indirect sp ,
1015 ] seq* [ one-param ] action ;
1017 : XOR-N-instruction ( -- parser )
1018 [
1019 "XOR-N" "XOR" complex-instruction ,
1020 "n" token sp hide ,
1021 ] seq* [ no-params ] action ;
1023 : XOR-R-instruction ( -- parser )
1024 [
1025 "XOR-R" "XOR" complex-instruction ,
1026 8-bit-registers sp ,
1027 ] seq* [ one-param ] action ;
1029 : XOR-(RR)-instruction ( -- parser )
1030 [
1031 "XOR-(RR)" "XOR" complex-instruction ,
1032 16-bit-registers indirect sp ,
1033 ] seq* [ one-param ] action ;
1035 : OR-N-instruction ( -- parser )
1036 [
1037 "OR-N" "OR" complex-instruction ,
1038 "n" token sp hide ,
1039 ] seq* [ no-params ] action ;
1041 : OR-R-instruction ( -- parser )
1042 [
1043 "OR-R" "OR" complex-instruction ,
1044 8-bit-registers sp ,
1045 ] seq* [ one-param ] action ;
1047 : OR-(RR)-instruction ( -- parser )
1048 [
1049 "OR-(RR)" "OR" complex-instruction ,
1050 16-bit-registers indirect sp ,
1051 ] seq* [ one-param ] action ;
1053 : CP-N-instruction ( -- parser )
1054 [
1055 "CP-N" "CP" complex-instruction ,
1056 "n" token sp hide ,
1057 ] seq* [ no-params ] action ;
1059 : CP-R-instruction ( -- parser )
1060 [
1061 "CP-R" "CP" complex-instruction ,
1062 8-bit-registers sp ,
1063 ] seq* [ one-param ] action ;
1065 : CP-(RR)-instruction ( -- parser )
1066 [
1067 "CP-(RR)" "CP" complex-instruction ,
1068 16-bit-registers indirect sp ,
1069 ] seq* [ one-param ] action ;
1071 : ADC-R,N-instruction ( -- parser )
1072 [
1073 "ADC-R,N" "ADC" complex-instruction ,
1074 8-bit-registers sp ,
1075 ",n" token hide ,
1076 ] seq* [ one-param ] action ;
1078 : ADC-R,R-instruction ( -- parser )
1079 [
1080 "ADC-R,R" "ADC" complex-instruction ,
1081 8-bit-registers sp ,
1082 "," token hide ,
1083 8-bit-registers ,
1084 ] seq* [ two-params ] action ;
1086 : ADC-R,(RR)-instruction ( -- parser )
1087 [
1088 "ADC-R,(RR)" "ADC" complex-instruction ,
1089 8-bit-registers sp ,
1090 "," token hide ,
1091 16-bit-registers indirect ,
1092 ] seq* [ two-params ] action ;
1094 : SBC-R,N-instruction ( -- parser )
1095 [
1096 "SBC-R,N" "SBC" complex-instruction ,
1097 8-bit-registers sp ,
1098 ",n" token hide ,
1099 ] seq* [ one-param ] action ;
1101 : SBC-R,R-instruction ( -- parser )
1102 [
1103 "SBC-R,R" "SBC" complex-instruction ,
1104 8-bit-registers sp ,
1105 "," token hide ,
1106 8-bit-registers ,
1107 ] seq* [ two-params ] action ;
1109 : SBC-R,(RR)-instruction ( -- parser )
1110 [
1111 "SBC-R,(RR)" "SBC" complex-instruction ,
1112 8-bit-registers sp ,
1113 "," token hide ,
1114 16-bit-registers indirect ,
1115 ] seq* [ two-params ] action ;
1117 : SUB-R-instruction ( -- parser )
1118 [
1119 "SUB-R" "SUB" complex-instruction ,
1120 8-bit-registers sp ,
1121 ] seq* [ one-param ] action ;
1123 : SUB-(RR)-instruction ( -- parser )
1124 [
1125 "SUB-(RR)" "SUB" complex-instruction ,
1126 16-bit-registers indirect sp ,
1127 ] seq* [ one-param ] action ;
1129 : SUB-N-instruction ( -- parser )
1130 [
1131 "SUB-N" "SUB" complex-instruction ,
1132 "n" token sp hide ,
1133 ] seq* [ no-params ] action ;
1135 : ADD-R,N-instruction ( -- parser )
1136 [
1137 "ADD-R,N" "ADD" complex-instruction ,
1138 8-bit-registers sp ,
1139 ",n" token hide ,
1140 ] seq* [ one-param ] action ;
1142 : ADD-R,R-instruction ( -- parser )
1143 [
1144 "ADD-R,R" "ADD" complex-instruction ,
1145 8-bit-registers sp ,
1146 "," token hide ,
1147 8-bit-registers ,
1148 ] seq* [ two-params ] action ;
1150 : ADD-RR,RR-instruction ( -- parser )
1151 [
1152 "ADD-RR,RR" "ADD" complex-instruction ,
1153 16-bit-registers sp ,
1154 "," token hide ,
1155 16-bit-registers ,
1156 ] seq* [ two-params ] action ;
1158 : ADD-R,(RR)-instruction ( -- parser )
1159 [
1160 "ADD-R,(RR)" "ADD" complex-instruction ,
1161 8-bit-registers sp ,
1162 "," token hide ,
1163 16-bit-registers indirect ,
1164 ] seq* [ two-params ] action ;
1166 : LD-RR,NN-instruction ( -- parser )
1167 ! LD BC,nn
1168 [
1169 "LD-RR,NN" "LD" complex-instruction ,
1170 16-bit-registers sp ,
1171 ",nn" token hide ,
1172 ] seq* [ one-param ] action ;
1174 : LD-R,N-instruction ( -- parser )
1175 ! LD B,n
1176 [
1177 "LD-R,N" "LD" complex-instruction ,
1178 8-bit-registers sp ,
1179 ",n" token hide ,
1180 ] seq* [ one-param ] action ;
1182 : LD-(RR),N-instruction ( -- parser )
1183 [
1184 "LD-(RR),N" "LD" complex-instruction ,
1185 16-bit-registers indirect sp ,
1186 ",n" token hide ,
1187 ] seq* [ one-param ] action ;
1189 : LD-(RR),R-instruction ( -- parser )
1190 ! LD (BC),A
1191 [
1192 "LD-(RR),R" "LD" complex-instruction ,
1193 16-bit-registers indirect sp ,
1194 "," token hide ,
1195 8-bit-registers ,
1196 ] seq* [ two-params ] action ;
1198 : LD-R,R-instruction ( -- parser )
1199 [
1200 "LD-R,R" "LD" complex-instruction ,
1201 8-bit-registers sp ,
1202 "," token hide ,
1203 8-bit-registers ,
1204 ] seq* [ two-params ] action ;
1206 : LD-RR,RR-instruction ( -- parser )
1207 [
1208 "LD-RR,RR" "LD" complex-instruction ,
1209 16-bit-registers sp ,
1210 "," token hide ,
1211 16-bit-registers ,
1212 ] seq* [ two-params ] action ;
1214 : LD-R,(RR)-instruction ( -- parser )
1215 [
1216 "LD-R,(RR)" "LD" complex-instruction ,
1217 8-bit-registers sp ,
1218 "," token hide ,
1219 16-bit-registers indirect ,
1220 ] seq* [ two-params ] action ;
1222 : LD-(NN),RR-instruction ( -- parser )
1223 [
1224 "LD-(NN),RR" "LD" complex-instruction ,
1225 "nn" token indirect sp hide ,
1226 "," token hide ,
1227 16-bit-registers ,
1228 ] seq* [ one-param ] action ;
1230 : LD-(NN),R-instruction ( -- parser )
1231 [
1232 "LD-(NN),R" "LD" complex-instruction ,
1233 "nn" token indirect sp hide ,
1234 "," token hide ,
1235 8-bit-registers ,
1236 ] seq* [ one-param ] action ;
1238 : LD-RR,(NN)-instruction ( -- parser )
1239 [
1240 "LD-RR,(NN)" "LD" complex-instruction ,
1241 16-bit-registers sp ,
1242 "," token hide ,
1243 "nn" token indirect hide ,
1244 ] seq* [ one-param ] action ;
1246 : LD-R,(NN)-instruction ( -- parser )
1247 [
1248 "LD-R,(NN)" "LD" complex-instruction ,
1249 8-bit-registers sp ,
1250 "," token hide ,
1251 "nn" token indirect hide ,
1252 ] seq* [ one-param ] action ;
1254 : OUT-(N),R-instruction ( -- parser )
1255 [
1256 "OUT-(N),R" "OUT" complex-instruction ,
1257 "n" token indirect sp hide ,
1258 "," token hide ,
1259 8-bit-registers ,
1260 ] seq* [ one-param ] action ;
1262 : IN-R,(N)-instruction ( -- parser )
1263 [
1264 "IN-R,(N)" "IN" complex-instruction ,
1265 8-bit-registers sp ,
1266 "," token hide ,
1267 "n" token indirect hide ,
1268 ] seq* [ one-param ] action ;
1270 : EX-(RR),RR-instruction ( -- parser )
1271 [
1272 "EX-(RR),RR" "EX" complex-instruction ,
1273 16-bit-registers indirect sp ,
1274 "," token hide ,
1275 16-bit-registers ,
1276 ] seq* [ two-params ] action ;
1278 : EX-RR,RR-instruction ( -- parser )
1279 [
1280 "EX-RR,RR" "EX" complex-instruction ,
1281 16-bit-registers sp ,
1282 "," token hide ,
1283 16-bit-registers ,
1284 ] seq* [ two-params ] action ;
1286 : 8080-generator-parser ( -- parser )
1287 [
1288 NOP-instruction ,
1289 RST-0-instruction ,
1290 RST-8-instruction ,
1291 RST-10H-instruction ,
1292 RST-18H-instruction ,
1293 RST-20H-instruction ,
1294 RST-28H-instruction ,
1295 RST-30H-instruction ,
1296 RST-38H-instruction ,
1297 JP-F|FF,NN-instruction ,
1298 JP-NN-instruction ,
1299 JP-(RR)-instruction ,
1300 CALL-F|FF,NN-instruction ,
1301 CALL-NN-instruction ,
1302 CPL-instruction ,
1303 CCF-instruction ,
1304 SCF-instruction ,
1305 DAA-instruction ,
1306 RLA-instruction ,
1307 RRA-instruction ,
1308 RLCA-instruction ,
1309 RRCA-instruction ,
1310 HALT-instruction ,
1311 DI-instruction ,
1312 EI-instruction ,
1313 AND-N-instruction ,
1314 AND-R-instruction ,
1315 AND-(RR)-instruction ,
1316 XOR-N-instruction ,
1317 XOR-R-instruction ,
1318 XOR-(RR)-instruction ,
1319 OR-N-instruction ,
1320 OR-R-instruction ,
1321 OR-(RR)-instruction ,
1322 CP-N-instruction ,
1323 CP-R-instruction ,
1324 CP-(RR)-instruction ,
1325 DEC-RR-instruction ,
1326 DEC-R-instruction ,
1327 DEC-(RR)-instruction ,
1328 POP-RR-instruction ,
1329 PUSH-RR-instruction ,
1330 INC-RR-instruction ,
1331 INC-R-instruction ,
1332 INC-(RR)-instruction ,
1333 LD-RR,NN-instruction ,
1334 LD-RR,RR-instruction ,
1335 LD-R,N-instruction ,
1336 LD-R,R-instruction ,
1337 LD-(RR),N-instruction ,
1338 LD-(RR),R-instruction ,
1339 LD-R,(RR)-instruction ,
1340 LD-(NN),RR-instruction ,
1341 LD-(NN),R-instruction ,
1342 LD-RR,(NN)-instruction ,
1343 LD-R,(NN)-instruction ,
1344 ADC-R,(RR)-instruction ,
1345 ADC-R,N-instruction ,
1346 ADC-R,R-instruction ,
1347 ADD-R,N-instruction ,
1348 ADD-R,(RR)-instruction ,
1349 ADD-R,R-instruction ,
1350 ADD-RR,RR-instruction ,
1351 SBC-R,N-instruction ,
1352 SBC-R,R-instruction ,
1353 SBC-R,(RR)-instruction ,
1354 SUB-R-instruction ,
1355 SUB-(RR)-instruction ,
1356 SUB-N-instruction ,
1357 RET-F|FF-instruction ,
1358 RET-NN-instruction ,
1359 OUT-(N),R-instruction ,
1360 IN-R,(N)-instruction ,
1361 EX-(RR),RR-instruction ,
1362 EX-RR,RR-instruction ,
1363 ] choice* [ call( -- quot ) ] action ;
1365 : instruction-quotations ( string -- emulate-quot )
1366 ! Given an instruction string, return the emulation quotation for
1367 ! it. This will later be expanded to produce the disassembly and
1368 ! assembly quotations.
1369 8080-generator-parser parse ;
1371 SYMBOL: last-instruction
1372 SYMBOL: last-opcode
1374 : parse-instructions ( list -- )
1375 ! Process the list of strings, which should make
1376 ! up an 8080 instruction, and output a quotation
1377 ! that would implement that instruction.
1378 dup " " join instruction-quotations
1379 [
1380 "_" join [ "emulate-" % % ] "" make create-word-in
1381 dup last-instruction set-global
1382 ] dip ( cpu -- ) define-declared ;
1384 SYNTAX: INSTRUCTION: ";" parse-tokens parse-instructions ;
1386 SYNTAX: cycles:
1387 ! Set the number of cycles for the last instruction that was defined.
1388 scan-token string>number last-opcode get-global instruction-cycles set-nth ;
1390 SYNTAX: opcode:
1391 ! Set the opcode number for the last instruction that was defined.
1392 last-instruction get-global 1quotation scan-token hex>
1393 dup last-opcode set-global set-instruction ;