1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;; and now
for something completely different
...
5 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 ;; Z80 Assembler
: input stream lexer
7 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10 on left paren
, lexer tries
to look forward
to create a better token
:
11 (HL
) -> uo
-r8
, kind
-(hl
)
12 (I
[XY
]) -> uo
-mrx16 kind
-i
[xy
]-none
13 (I
[XY
]+ -> uo
-mrx16 kind
-i
[xy
]-add
14 (I
[XY
]- -> uo
-mrx16 kind
-i
[xy
]-sub
16 (BC
), (DE
), (SP
) -> uo
-mr16 with proper kind
18 "C" is always r8
. to convert it
to condition
, use
"token-c-to-cond".
19 to convert
"(HL)" to r8 use
"token-(hl)->r8"
23 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24 ;; simple expression evaluator
27 ;; cannot include instrs here
28 vocab
-if-none asm
-instr
31 vocab
-if-none asm
-lexer
35 true value allow
-continuations
36 ;; for label detection
40 ;; one
-char and two
-char strings sets
"TOK-NUM" too
41 ;; number sign is not parsed
47 def
: tk
-punct
;; punctuation
; sets both
"TK-STR" and
"TK-NUM" (to char code
)
48 def
: tk
-label
;; line start
, word ends with
":"; token is without
":"
49 def
: tk
-mnemo
;; mnemonics
;; TK
-STR contains a word
(uppercased
); TOK
-MNEMO
-CFA is CFA
50 def
: tk
-resw
;; reserved word
; TK
-STR contains a word
(uppercased
); TOK
-UO is UO
-xxx
; TOK
-KIND is kind
55 0 value tok
-type
;; TK
-xxx
58 0 value tok
-kind
;; for reserved words
62 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
68 : is
-digit
( ch
-- bool
)
69 [char
] 0 [char
] 9 bounds?
72 : is
-bin
-digit
( ch
-- bool
)
73 [char
] 0 [char
] 1 bounds?
76 : is
-oct
-digit
( ch
-- bool
)
77 [char
] 0 [char
] 7 bounds?
80 : is
-hex
-digit
( ch
-- bool
)
81 dup
[char
] 0 [char
] 9 bounds?
82 over
[char
] A
[char
] F bounds? or
83 swap
[char
] a
[char
] f bounds? or
86 : is
-alpha
( ch
-- bool
)
87 dup
[char
] A
[char
] Z bounds?
88 swap
[char
] a
[char
] z bounds? or
91 : is
-under
-dot
( ch
-- bool
)
96 : is
-alpha
-under
-dot
( ch
-- bool
)
97 dup is
-alpha swap is
-under
-dot or
100 : is
-alnum
( ch
-- bool
)
101 dup is
-alpha swap is
-digit or
104 : is
-id
-start
( ch
-- bool
)
105 dup is
-alpha swap is
-under
-dot or
108 : is
-id
-char
( ch
-- bool
)
109 dup is
-id
-start swap is
-digit or
113 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
118 tok
-type tk
-punct
= swap tok
-num
= and
121 : punct2?
( char
-- )
122 tok
-type tk
-punct
= swap
0xff and dup
8 ash or tok
-num
= and
126 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
127 ;; input stream tokenizer
131 ;; return current token string
132 ;; valid until
"next-token" is called
133 : token
( -- addr count
) tok
-addr tok
-len
;
136 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
143 tk
-eos of
." <EOS>\n" endof
144 tk
-id of
." <ID>; str=<" token xtype
." >\n" endof
145 tk
-num of
." <NUM>; num=" tok
-num
. ." str=<" token xtype
." >\n" endof
146 tk
-str of
." <STR>; str=<" token xtype
." >\n" endof
147 tk
-punct of
." <PUNCT>; num=" tok
-num
. ." str=<" token xtype
." >\n" endof
148 tk
-label of
." <LABEL>; str=<" token xtype
." >\n" endof
149 tk
-mnemo of
." <MNEMO>; str=<" token xtype
." > cfa=" tok
-mnemo
-cfa
0 .r cr endof
150 tk
-resw of
." <RES-WORD>; str=<" token xtype
." > uo=" tok
-uo
. ." kind=" tok
-kind
0 .r cr endof
151 otherwise
. " wutafuck?" error
156 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
161 : char
-upper
( ch
-- )
162 dup
[char
] a
[char
] z bounds?
if 32 - endif
165 : (init
-tok
-addr
) ( -- ) (tib
-in
) to tok
-addr
;
166 : (init
-tok
) ( -- ) (init
-tok
-addr
) 0 to tok
-len
;
167 ;; set length according
to the current TIB position
168 ;; (init
-tok
-addr
) must be already called
169 : (tok
-fix
-length
) ( -- ) (tib
-in
) tok
-addr
- to tok
-len
;
171 : (set
-eos
) ( -- ) (init
-tok
) tk
-eos
to tok
-type
;
173 : (collect
-punct
) ( -- )
177 tib
-peekch
[char
] & = if tib
-skipch
endif
180 tib
-peekch
[char
] |
= if tib
-skipch
endif
184 [char
] = of tib
-skipch endof
185 [char
] < of tib
-skipch endof
186 [char
] > of tib
-skipch endof
191 [char
] = of tib
-skipch endof
192 [char
] > of tib
-skipch endof
196 tib
-peekch
[char
] = = if tib
-skipch
endif
200 tok
-addr tok
-len case
203 3 of dup w@ swap
2+ c@
16 lsh or endof
205 otherwise
" wut?!" error
210 : (collect
) ( checkcfa
-- )
211 >r begin tib
-peekch dup
0<> swap r@ execute and
217 : (collect
-id
) ( -- )
218 (init
-tok
) ['] is-id-char (collect)
222 : (other-pfx-dblch) ( ch -- )
224 >r tib-peekch r@ = if ;; "$$", etc.
225 tib-skipch tib-peekch r> = " invalid identifier" ?error
226 tib-peekch is-id-char if
227 +1-to tok-addr ;; convert "@@f" to "@f"
228 ['] is
-id
-char
(collect
)
229 else (tok
-fix
-length
) endif
230 line
-start
if tk
-label
to tok
-type
endif
231 else rdrop
['] is-id-char (collect) endif
234 ;; we are at one-char prefix, it may be a number
235 ;; it it isn't
, colled as punctuation
236 : (try
-pfx
-num
) ( checkcfa
-- )
238 tib
-peekch swap execute
if
239 ['] is-id-char (collect)
240 ;; (XNUMBER) ( addr count allowsign? -- num TRUE / FALSE )
241 token false base @ (based-number) " invalid number" ?not-error
242 to tok-num tk-num to tok-type
243 else ;; "$" is identifier
244 tok-addr c@ [char] $ = if [char] $ (other-pfx-dblch) endif
249 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
253 : (classify-id-mnemo?) ( -- success-bool )
254 token vocid: asm-instr find-word-in-voc
256 swap to tok-mnemo-cfa
263 tok
-kind asm
-resw
:kind
-af
= if
264 tib
-peekch
[char
] ' = if
265 tib-skipch (tok-fix-length)
266 asm-resw:uo-afx to tok-uo
271 : (classify-id-resw?) ( -- success-bool )
272 token vocid: asm-resw find-word-in-voc
273 dup if drop ( cfa: UO-xxx kind )
274 cfa->pfa dup @ to tok-uo
283 : (classify
-id
-label
-colon?
) ( -- success
-bool
)
284 line
-start dup
if drop
286 tib
-peekch
[char
] : = if tib
-skipch
288 tok
-addr c@ is
-digit
" invalid label" ?error
295 : (classify
-id
-label?
) ( -- success
-bool
)
296 line
-start dup
if drop
298 tok
-addr c@ is
-digit not
if
307 : (classify
-id
-number?
) ( -- success
-bool
)
308 tok
-addr c@ is
-digit
if
309 token false base @
(based
-number
) " invalid number" ?not
-error
317 : (classify
-id
-maybe
-number?
) ( -- success
-bool
)
318 tok
-addr c@ is
-id
-char not
if
319 token false
(based
-number
) if
330 ' (classify-id-mnemo?) ,
331 ' (classify
-id
-resw?
) ,
332 ' (classify-id-label-colon?) ,
333 ' (classify
-id
-label?
) ,
334 ' (classify-id-number?) ,
335 ' (classify
-id
-maybe
-number?
) ,
339 : (classify
-id
) ( -- )
344 execute
if drop exit
endif cell
+
349 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
353 : byte
-swap
( word
-- word
)
355 swap
-8 lsh
0xff and or
358 ;;FIXME
: escape support?
359 : (collect
-char
-string
) ( -- )
361 (init
-tok
) begin tib
-getch dup
" unterminated string" ?not
-error
363 (tok
-fix
-length
) tok
-len
0> " invalid string" ?not
-error
364 -1-to tok
-len
;; final quote fix
367 1 of tok
-addr c@
to tok
-num endof
369 tok
-addr w@ r@
[char
] " <> if byte-swap endif ;; "
372 otherwise drop
-1 to tok
-num
378 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
379 ;; parse
"(" (extended
)
382 : (skip
-chars
) ( count
-- ) for tib
-skipch endfor
;
384 : (blank
-char?
) ( ch
-- ) dup
0> swap bl
<= and
;
386 ;; skip blanks until non
-blank or EOL
387 ;; eofs is at non
-blank or EOL
388 : (lparen
-skip
-blanks
) ( stofs
-- eofs char
)
389 begin
1+ dup
1- tib
-peekch
-ofs
(blank
-char?
) not
-until
1-
393 ;; skip blanks
, check
for ")"
395 : (check
-rparen
) ( stofs
-- eofs TRUE
/ FALSE
)
397 [char
] ) = if 1+ true
else drop false
endif
400 ;; "(c"; TIB is at
"c"
401 : (try
-lparen
-c
) ( -- )
403 (skip
-chars
) (tok
-fix
-length
)
405 asm
-resw
:uo
-portc
to tok
-uo
409 ;; "(.."; TIB is at the first char
410 : (try
-lparen
-r16
) ( kind char2
-- )
411 1 tib
-peekch
-ofs char
-upper
= if
413 (skip
-chars
) (tok
-fix
-length
)
415 asm
-resw
:uo
-mr16
to tok
-uo
423 : (try
-lparen
-bc
) ( -- ) asm
-resw
:kind
-bc
[char
] C
(try
-lparen
-r16
) ;
424 : (try
-lparen
-de
) ( -- ) asm
-resw
:kind
-de
[char
] E
(try
-lparen
-r16
) ;
425 : (try
-lparen
-sp
) ( -- ) asm
-resw
:kind
-sp
[char
] P
(try
-lparen
-r16
) ;
426 : (try
-lparen
-hl
) ( -- )
427 asm
-resw
:kind
-(hl
) [char
] L
(try
-lparen
-r16
)
428 tok
-uo asm
-resw
:uo
-mr16
= if asm
-resw
:uo
-r8
to tok
-uo
endif
431 ;; most
complex checker
: "(i[xy][+-]"
433 : (try
-lparen
-ixy
) ( -- )
434 ;; parse
, put initial kind on the stack
435 1 tib
-peekch
-ofs char
-upper case
436 [char
] X of asm
-resw
:kind
-ix
-none endof
437 [char
] Y of asm
-resw
:kind
-iy
-none endof
440 ( kind
; check
if we have
+ or
- )
441 2 (lparen
-skip
-blanks
) ( base
-kind ch
-ofs char
)
443 [char
] + of asm
-resw
:kind
-ix
-add endof
444 [char
] - of asm
-resw
:kind
-ix
-sub endof
448 ( base
-kind ch
-ofs ext
-kind
)
449 rot
+ swap
1+ (skip
-chars
) (tok
-fix
-length
)
451 asm
-resw
:uo
-mrx16
to tok
-uo
456 ;; something that starts with
"(".
458 ;; uo
-mr16
-- "(r16)"
459 ;; uo
-mrx16
-- "(i[xy][+-]"
461 : (check
-lparen
) ( -- )
463 parse
-skip
-blanks
;; why not? allow
"( hl )"
464 tib
-peekch char
-upper case
465 [char
] I of
(try
-lparen
-ixy
) endof
466 [char
] C of
(try
-lparen
-c
) endof
467 [char
] B of
(try
-lparen
-bc
) endof
468 [char
] D of
(try
-lparen
-de
) endof
469 [char
] H of
(try
-lparen
-hl
) endof
470 [char
] S of
(try
-lparen
-sp
) endof
475 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
476 ;; read and classify next token from the input stream
481 \
." =====NEXT-TOKEN!" cr debug
:dump
-stack
484 0 of
(set
-eos
) true endof
485 bl
<=of tib
-skipch false endof
486 [char
] ; of
(set
-eos
) parse
-skip
-line true endof
487 [char
] % of
['] is-bin-digit (try-pfx-num) true endof
488 [char] $ of ['] is
-hex
-digit
(try
-pfx
-num
) true endof
489 [char
] # of
['] is-hex-digit (try-pfx-num) tok-type tk-num <> " hex number expected" ?error true endof
491 (tib-in) 1+ c@ char-upper
493 [char] H of true endof
494 [char] B of (tib-in) 2+ c@ is-bin-digit endof
495 [char] O of true endof
498 if ['] is
-hex
-digit
(try
-pfx
-num
) tok
-type tk
-num
<> " hex number expected" ?error
499 else (collect
-punct
) endif
503 (collect
-punct
) (check
-lparen
)
507 (collect
-punct
) [char
] @
(other
-pfx
-dblch
)
508 (classify
-id
-label
-colon?
) ifnot
(classify
-id
-label?
) drop
endif
511 [char
] ' of (collect-char-string) true endof ;; '
512 [char
] " of (collect-char-string) true endof ;; "
513 [char
] ` of
(collect
-char
-string
) true endof
;; `
514 [char
] \ of
;; possible continuation
516 allow
-continuations
if
519 else refill
-nocross
" unexpected end of file in line continuation" ?not
-error false
525 is
-id
-char
if (collect
-id
) (classify
-id
) else (collect
-punct
) endif
530 \
." |" TOKEN XTYPE
." | -- " TIB
-PEEKCH XEMIT CR
535 : token
-eol?
( -- bool
) tok
-type tk
-eos
= ;
536 : token
-colon?
( -- bool
) tok
-type tk
-punct
= tok
-num
[char
] : = and
;
537 : token
-comma?
( -- bool
) tok
-type tk
-punct
= tok
-num
[char
] , = and
;
538 : token
-lparen?
( -- bool
) tok
-type tk
-punct
= tok
-num
[char
] ( = and
; ;; )
539 : token
-rparen?
( -- bool
) tok
-type tk
-punct
= tok
-num
[char
] ) = and
;
540 : token
-=?
( -- bool
) tok
-type tk
-punct
= tok
-num
[char
] = = and
;
542 ;; are we at
end of line
(real EOL
, or
":")?
543 : token
-colon
-eol?
( -- bool
) token
-eol? token
-colon? or
;
545 : token
-resw?
( -- bool
) tok
-type tk
-resw
= ;
546 : token
-uo?
( uo
-- bool
) tok
-uo
= token
-resw? and
;
547 : token
-uo
-kind?
( uo kind
-- bool
) tok
-kind
= swap tok
-uo
= and token
-resw? and
;
549 : token
-regA?
( -- bool
) asm
-resw
:uo
-r8 asm
-resw
:kind
-a token
-uo
-kind?
;
550 : token
-regIR?
( -- bool
) asm
-resw
:uo
-sr8 token
-uo?
;
551 : token
-r8?
( -- bool
) asm
-resw
:uo
-r8 token
-uo?
;
552 : token
-rx8?
( -- bool
) asm
-resw
:uo
-rx8 token
-uo?
;
553 : token
-r16?
( -- bool
) asm
-resw
:uo
-r16 token
-uo?
;
554 : token
-af?
( -- bool
) asm
-resw
:uo
-r16 asm
-resw
:kind
-af token
-uo
-kind?
;
555 : token
-afx?
( -- bool
) asm
-resw
:uo
-afx token
-uo?
;
556 : token
-bc?
( -- bool
) asm
-resw
:uo
-r16 asm
-resw
:kind
-bc token
-uo
-kind?
;
557 : token
-de?
( -- bool
) asm
-resw
:uo
-r16 asm
-resw
:kind
-de token
-uo
-kind?
;
558 : token
-hl?
( -- bool
) asm
-resw
:uo
-r16 asm
-resw
:kind
-hl token
-uo
-kind?
;
559 : token
-sp?
( -- bool
) asm
-resw
:uo
-r16 asm
-resw
:kind
-sp token
-uo
-kind?
;
560 : token
-ix?
( -- bool
) asm
-resw
:uo
-rx16 asm
-resw
:kind
-ix token
-uo
-kind?
;
561 : token
-iy?
( -- bool
) asm
-resw
:uo
-rx16 asm
-resw
:kind
-iy token
-uo
-kind?
;
562 : token
-ixy?
( -- bool
) asm
-resw
:uo
-rx16 token
-uo?
;
563 : token
-mr16?
( -- bool
) asm
-resw
:uo
-mr16 token
-uo?
;
564 : token
-(hl
)?
( -- bool
) asm
-resw
:uo
-r8 asm
-resw
:kind
-(hl
) token
-uo
-kind?
;
565 : token
-(bc
)?
( -- bool
) asm
-resw
:uo
-mr16 asm
-resw
:kind
-bc token
-uo
-kind?
;
566 : token
-(sp
)?
( -- bool
) asm
-resw
:uo
-mr16 asm
-resw
:kind
-sp token
-uo
-kind?
;
567 : token
-(ixy
)?
( -- bool
) asm
-resw
:uo
-mrx16 token
-uo?
;
568 : token
-(c
)?
( -- bool
) asm
-resw
:uo
-portc token
-uo?
;
569 : token
-r16
-n?
( -- bool
) asm
-resw
:uo
-r16 token
-uo? tok
-kind asm
-resw
:kind
-sp
<= and
;
570 : token
-r16
-x?
( -- bool
) asm
-resw
:uo
-r16 token
-uo? tok
-kind asm
-resw
:kind
-hl
<= and
;
571 : token
-mr16
-x?
( -- bool
) asm
-resw
:uo
-mr16 token
-uo? tok
-kind asm
-resw
:kind
-hl
<= and
;
572 : token
-reg
-c?
( -- bool
) asm
-resw
:uo
-r8 asm
-resw
:kind
-c token
-uo
-kind?
;
573 : token
-equ?
( -- bool
) asm
-resw
:uo
-equ token
-uo?
;
574 : token
-(c
)/(bc
)?
( -- bool
) token
-(c
)? token
-(bc
)? or
;
576 : token
-(hl
)->mr16
( -- )
577 token
-(hl
)?
if asm
-resw
:uo
-mr16
to tok
-uo asm
-resw
:kind
-hl
to tok
-kind
endif
580 ;; converts C register
to condition
581 : token
-c
-to-cond
( -- )
583 asm
-resw
:uo
-cond
to tok
-uo
584 asm
-resw
:kind
-cc
to tok
-kind
588 : token
-cond?
( -- bool
)
589 token
-reg
-c?
if token
-c
-to-cond true
590 else asm
-resw
:uo
-cond token
-uo?
595 : (build
-expector
) ( -- ) \ name checker msg|
596 parse
-name dup
" name expected" ?not
-error
597 compiler
:(create
-forth
-header
) [compile
] ]
599 parse
-skip
-blanks
[char
] | parse
" message expected" ?not
-error strliteral
603 : (build
-expector
-finish
) ( -- )
604 compile next
-token compile forth
:(exit
) [compile
] [
608 : build
-expector
: ( -- ) \ name checker msg|
609 (build
-expector
) (build
-expector
-finish
)
612 : build
-expector
-res
: ( -- ) \ name checker msg|
613 (build
-expector
) compile tok
-kind
(build
-expector
-finish
)
616 build
-expector
: expect
-eol token
-eol?
end of line expected|
617 build
-expector
: expect
-comma token
-comma? comma expected|
618 build
-expector
: expect
-lparen token
-lparen? `
(` expected|
619 build
-expector
: expect
-rparen token
-rparen? `
)` expected|
620 build
-expector
: expect
-regA token
-regA? `A` register expected|
621 build
-expector
: expect
-(c
) token
-(c
)? `
(C
)` expected|
622 build
-expector
: expect
-(c
)/(bc
) token
-(c
)/(bc
)? `
(C
)` expected|
624 build
-expector
-res
: expect
-cond token
-cond? condition code expected|
625 build
-expector
-res
: expect
-r8 token
-r8?
8-bit register expected|
626 build
-expector
-res
: expect
-r16 token
-r16?
16-bit register expected|