urasm: implemented "$printf"

[urasm.git] / urflibs / urasm / lexer.f

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; and now for something completely different...
;; UrAsm Forth Engine!
;; GPLv3 ONLY
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Z80 Assembler: input stream lexer
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(*
  on left paren, lexer tries to look forward to create a better token:
    (HL) -> uo-r8, kind-(hl)
    (I[XY]) -> uo-mrx16 kind-i[xy]-none
    (I[XY]+ -> uo-mrx16 kind-i[xy]-add
    (I[XY]- -> uo-mrx16 kind-i[xy]-sub
    (C) -> uo-portc
    (BC), (DE), (SP) -> uo-mr16 with proper kind

  "C" is always r8. to convert it to condition, use "token-c-to-cond".
  to convert "(HL)" to r8 use "token-(hl)->r8"
*)


;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; simple expression evaluator
;;

;; cannot include instrs here
vocab-if-none asm-instr


vocab-if-none asm-lexer
also-defs: asm-lexer

;; options
false value allow-continuations
;; for label detection
true value line-start


;; one-char and two-char strings sets "TOK-NUM" too
;; number sign is not parsed
enum{
  def: tk-eos
  def: tk-id
  def: tk-num
  def: tk-str
  def: tk-punct  ;; punctuation; sets both "TK-STR" and "TK-NUM" (to char code)
  def: tk-label  ;; line start, word ends with ":"; token is without ":"
  def: tk-mnemo  ;; mnemonics;; TK-STR contains a word (uppercased); TOK-MNEMO-CFA is CFA
  def: tk-resw   ;; reserved word; TK-STR contains a word (uppercased); TOK-UO is UO-xxx; TOK-KIND is kind
}

0 value tok-addr
0 value tok-len
0 value tok-type  ;; TK-xxx
0 value tok-num
0 value tok-uo
0 value tok-kind  ;; for reserved words
0 value tok-mnemo-cfa


;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; warning reports
;;

<public-words>

: warning  ( addr count -- )
  endcr ." WARNING at "
  0 (include-file-name) xtype ." :" 0 (include-file-line) 0 .r
  ." : " xtype cr
;


;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; char classifiers
;;

<public-words>

: is-digit  ( ch -- bool )
  [char] 0 [char] 9 bounds?
;

: is-bin-digit  ( ch -- bool )
  [char] 0 [char] 1 bounds?
;

: is-oct-digit  ( ch -- bool )
  [char] 0 [char] 7 bounds?
;

: is-hex-digit  ( ch -- bool )
  dup [char] 0 [char] 9 bounds?
  over [char] A [char] F bounds? or
  swap [char] a [char] f bounds? or
;

: is-alpha  ( ch -- bool )
  dup [char] A [char] Z bounds?
  swap [char] a [char] z bounds? or
;

: is-under-dot  ( ch -- bool )
  dup [char] _ =
  swap [char] . = or
;

: is-alpha-under-dot  ( ch -- bool )
  dup is-alpha swap is-under-dot or
;

: is-alnum  ( ch -- bool )
  dup is-alpha swap is-digit or
;

: is-id-start  ( ch -- bool )
  dup is-alpha swap is-under-dot or
;

: is-id-char  ( ch -- bool )
  dup is-id-start swap is-digit or
;


;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; token checks
;;

: punct?  ( char -- )
  tok-type tk-punct = swap tok-num = and
;

: punct2?  ( char -- )
  tok-type tk-punct = swap 0xff and dup 8 ash or tok-num = and
;


;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; input stream tokenizer
;;
<public-words>

;; return current token string
;; valid until "next-token" is called
: token  ( -- addr count )  tok-addr tok-len ;


;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; debug
;;

: dump-token  ( -- )
  ." *** TOKEN: type="
  tok-type case
    tk-eos of ." <EOS>\n" endof
    tk-id  of ." <ID>; str=<" token xtype ." >\n" endof
    tk-num of ." <NUM>; num=" tok-num . ." str=<" token xtype ." >\n" endof
    tk-str of ." <STR>; str=<" token xtype ." >\n" endof
    tk-punct of ." <PUNCT>; num=" tok-num . ." str=<" token xtype ." >\n" endof
    tk-label of ." <LABEL>; str=<" token xtype ." >\n" endof
    tk-mnemo of ." <MNEMO>; str=<" token xtype ." > cfa=" tok-mnemo-cfa 0 .r cr endof
    tk-resw of ." <RES-WORD>; str=<" token xtype ." > uo=" tok-uo . ." kind=" tok-kind 0 .r cr endof
    otherwise . " wutafuck?" error
  endcase
;


;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; tokenizer helpers
;;
<hidden-words>

: char-upper  ( ch -- )
  dup [char] a [char] z bounds? if 32 - endif
;

: (init-tok-addr)  ( -- )  (tib-in) to tok-addr ;
: (init-tok)  ( -- )  (init-tok-addr) 0 to tok-len ;
;; set length according to the current TIB position
;; (init-tok-addr) must be already called
: (tok-fix-length)  ( -- ) (tib-in) tok-addr - to tok-len ;

: (set-eos)  ( -- ) (init-tok) tk-eos to tok-type ;

: (collect-punct)  ( -- )
  (init-tok-addr)
  tib-getch case
    [char] & of
        tib-peekch [char] & = if tib-skipch endif
      endof
    [char] | of
        tib-peekch [char] | = if tib-skipch endif
      endof
    [char] < of
        tib-peekch case
          [char] = of tib-skipch endof
          [char] < of tib-skipch endof
          [char] > of tib-skipch endof
        endcase
      endof
    [char] > of
        tib-peekch case
          [char] = of tib-skipch endof
          [char] > of tib-skipch endof
        endcase
      endof
    [char] ! of
        tib-peekch [char] = = if tib-skipch endif
      endof
    [char] = of
        tib-peekch [char] = = if tib-skipch endif
      endof
  endcase
  (tok-fix-length)
  tok-addr tok-len case
    1 of c@ endof
    2 of w@ endof
    3 of dup w@ swap 2+ c@ 16 lsh or endof
    4 of @ endof
    otherwise " wut?!" error
  endcase to tok-num
  tk-punct to tok-type
;

: (collect)  ( checkcfa -- )
  >r begin tib-peekch dup 0<>  swap r@ execute and
  while tib-skipch
  repeat rdrop
  (tok-fix-length)
;

: (collect-id)  ( -- )
  (init-tok) ['] is-id-char (collect)
  tk-id to tok-type
;

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; identifier classifiers
;;

: (classify-id-mnemo?)  ( -- success-bool )
  token vocid: asm-instr find-word-in-voc
  dup if
    swap to tok-mnemo-cfa
    tk-mnemo to tok-type
    \ token string:upper
  endif
;

: (check-af')  ( -- )
  tok-kind asm-resw:kind-af = if
    tib-peekch [char] ' = if
      tib-skipch (tok-fix-length)
      asm-resw:uo-afx to tok-uo
    endif
  endif
;

: (classify-id-resw?)  ( -- success-bool )
  token vocid: asm-resw find-word-in-voc
  dup if drop  ( cfa: UO-xxx kind )
    cfa->pfa dup @ to tok-uo
    cell+ @ to tok-kind
    tk-resw to tok-type
    (check-af')
    \ token string:upper
    true
  endif
;

: (classify-id-label-colon?)  ( -- success-bool )
  line-start dup if drop
    parse-skip-blanks
    tib-peekch [char] : = if tib-skipch
      tk-label to tok-type
      tok-addr c@ is-digit " invalid label" ?error
      true
    else false
    endif
  endif
;

: (classify-id-label?)  ( -- success-bool )
  line-start dup if drop
    tok-addr tib @ = if
      tok-addr c@ is-digit not if
        tk-label to tok-type
        true
      else false
      endif
    else false endif
  endif
;

: (classify-id-number?)  ( -- success-bool )
  tok-addr c@ is-digit if
    token false base @ (based-number) " invalid number" ?not-error
    to tok-num
    tk-num to tok-type
    true
  else false
  endif
;

: (classify-id-maybe-number?)  ( -- success-bool )
  tok-addr c@ is-id-char not if
    token false (based-number) if
      to tok-num
      tk-num to tok-type
      true
    else false
    endif
  else false
  endif
;

create (classifiers)
  ' (classify-id-mnemo?) ,
  ' (classify-id-resw?) ,
  ' (classify-id-label-colon?) ,
  ' (classify-id-label?) ,
  ' (classify-id-number?) ,
  ' (classify-id-maybe-number?) ,
  0 ,
create;

: (run-classifiers)  ( arr-addr -- )
  begin dup @ ?dup
  while ( addr cfa ) execute if drop exit endif cell+
  repeat drop
;

: (classify-id)  ( -- )
  tok-len 127 > " token too long" ?error
  (classifiers) (run-classifiers)
;

: (classify-id-no-label)  ( -- )
  tok-type tk-id = if
    tok-len 127 > " token too long" ?error
    \ (classifiers-no-label) (run-classifiers)
    (classify-id-mnemo?) drop
  endif
;

: (classify-id-label)  ( -- )
  tok-type tk-id = if
    tok-len 127 > " token too long" ?error
    \ (classifiers-no-label) (run-classifiers)
    (classify-id-label-colon?) ifnot (classify-id-label?) drop endif
  endif
;

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; number-like collectors
;;

: (other-pfx-dblch)  ( ch -- )
  tk-id to tok-type
  >r tib-peekch r@ = if  ;; "$$", etc.
    tib-skipch tib-peekch r> = " invalid identifier" ?error
    tib-peekch is-id-char if
      +1-to tok-addr  ;; convert "@@f" to "@f"
      ['] is-id-char (collect)
    else (tok-fix-length) endif
    line-start if tk-label to tok-type endif
  else rdrop ['] is-id-char (collect) endif
  tok-len 127 > " token too long" ?error
;

;; we are at one-char prefix, it may be a number
;; it it isn't, colled as punctuation
: (try-pfx-num) ( checkcfa -- )
  (collect-punct)
  tib-peekch swap execute if
    ['] is-id-char (collect)
    ;; (XNUMBER) ( addr count allowsign? -- num TRUE / FALSE )
    token false base @ (based-number) ifnot
      (classify-id-mnemo?) " invalid number" ?not-error
    else
      to tok-num  tk-num to tok-type
    endif
  else  ;; "$" is identifier
    tok-addr c@ [char] $ = if [char] $ (other-pfx-dblch) endif
  endif
;


;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; quoted something
;;

: byte-swap  ( word -- word )
  dup 0xff and 8 lsh
  swap -8 lsh 0xff and or
;

;;FIXME: escape support?
: (collect-char-string)  ( -- )
  tib-getch >r
  (init-tok) begin tib-getch dup " unterminated string" ?not-error
  r@ = until
  (tok-fix-length) tok-len 0> " invalid string" ?not-error
  -1-to tok-len  ;; final quote fix
  tk-str to tok-type
  tok-len case
    1 of tok-addr c@ to tok-num endof
    2 of
        tok-addr w@ r@ [char] " <> if byte-swap endif  ;; "
        to tok-num
      endof
    otherwise drop -1 to tok-num
  endcase
  rdrop
;


;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; parse "(" (extended)
;;

: (skip-chars)  ( count -- )  for tib-skipch endfor ;

: (blank-char?)  ( ch -- )  dup 0> swap bl <= and ;

;; skip blanks until non-blank or EOL
;; eofs is at non-blank or EOL
: (lparen-skip-blanks)  ( stofs -- eofs char )
  begin 1+ dup 1- tib-peekch-ofs (blank-char?) not-until 1-
  dup tib-peekch-ofs
;

;; skip blanks, check for ")"
;; eofs is AFTER ")"
: (check-rparen)  ( stofs -- eofs TRUE / FALSE )
  (lparen-skip-blanks)
  [char] ) = if 1+ true else drop false endif
;

;; "(c"; TIB is at "c"
: (try-lparen-c)  ( -- )
  1 (check-rparen) if
    (skip-chars) (tok-fix-length)
    tk-resw to tok-type
    asm-resw:uo-portc to tok-uo
  endif
;

;; "(.."; TIB is at the first char
: (try-lparen-r16)  ( kind char2 -- )
  1 tib-peekch-ofs char-upper = if
    2 (check-rparen) if
      (skip-chars) (tok-fix-length)
      tk-resw to tok-type
      asm-resw:uo-mr16 to tok-uo
      to tok-kind
    else drop
    endif
  else drop
  endif
;

: (try-lparen-bc)  ( -- )  asm-resw:kind-bc [char] C (try-lparen-r16) ;
: (try-lparen-de)  ( -- )  asm-resw:kind-de [char] E (try-lparen-r16) ;
: (try-lparen-sp)  ( -- )  asm-resw:kind-sp [char] P (try-lparen-r16) ;
: (try-lparen-hl)  ( -- )
  asm-resw:kind-(hl) [char] L (try-lparen-r16)
  tok-uo asm-resw:uo-mr16 = if asm-resw:uo-r8 to tok-uo endif
;

;; most complex checker: "(i[xy][+-]"
;; TIB is at "I"
: (try-lparen-ixy)  ( -- )
  ;; parse, put initial kind on the stack
  1 tib-peekch-ofs char-upper case
    [char] X of asm-resw:kind-ix-none endof
    [char] Y of asm-resw:kind-iy-none endof
    otherwise drop exit
  endcase
  ( kind; check if we have + or - )
  2 (lparen-skip-blanks)  ( base-kind ch-ofs char )
  case
    [char] + of asm-resw:kind-ix-add endof
    [char] - of asm-resw:kind-ix-sub endof
    [char] ) of 0 endof
    otherwise drop exit
  endcase
  ( base-kind ch-ofs ext-kind )
  rot + swap 1+ (skip-chars) (tok-fix-length)
  tk-resw to tok-type
  asm-resw:uo-mrx16 to tok-uo
  to tok-kind
;


;; something that starts with "(".
;; it can be:
;;   uo-mr16 -- "(r16)"
;;   uo-mrx16 -- "(i[xy][+-]"
;;   uo-portc -- "(c)"
: (check-lparen) ( -- )
  ;; check next char
  parse-skip-blanks  ;; why not? allow "( hl )"
  tib-peekch char-upper case
    [char] I of (try-lparen-ixy) endof
    [char] C of (try-lparen-c) endof
    [char] B of (try-lparen-bc) endof
    [char] D of (try-lparen-de) endof
    [char] H of (try-lparen-hl) endof
    [char] S of (try-lparen-sp) endof
  endcase
;


;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; read and classify next token from the input stream
;;
<public-words>

: next-token  ( -- )
   \ ." =====NEXT-TOKEN!" cr debug:dump-stack
  begin
    tib-peekch case
      0 of (set-eos) true endof
      bl <=of tib-skipch false endof
      [char] ; of (set-eos) parse-skip-line true endof
      [char] % of ['] is-bin-digit (try-pfx-num) true endof
      [char] $ of ['] is-hex-digit (try-pfx-num) (classify-id-no-label) true endof
      [char] # of ['] is-hex-digit (try-pfx-num) tok-type tk-num <> " hex number expected" ?error true endof
      [char] & of
          (tib-in) 1+ c@ char-upper
          case
            [char] H of true endof
            [char] B of (tib-in) 2+ c@ is-bin-digit endof
            [char] O of true endof
            otherwise drop false
          endcase
          if ['] is-hex-digit (try-pfx-num) tok-type tk-num <> " hex number expected" ?error
          else (collect-punct) endif
          true
        endof
      [char] ( of  ;; )
          (collect-punct) (check-lparen)
          true
        endof
      [char] @ of (collect-punct) [char] @ (other-pfx-dblch) (classify-id-label) true endof
      [char] ' of (collect-char-string) true endof  ;; '
      [char] " of (collect-char-string) true endof  ;; "
      [char] ` of (collect-char-string) true endof  ;; `
      [char] \ of  ;; possible continuation
          (collect-punct)
          allow-continuations if
            parse-skip-blanks
            tib-peekch if true
            else refill-nocross " unexpected end of file in line continuation" ?not-error false
            endif
          else true
          endif
        endof
      otherwise
        is-id-char if (collect-id) (classify-id) else (collect-punct) endif
        true
    endcase
  until
  false to line-start
   \ ." |" TOKEN XTYPE ." | -- " TIB-PEEKCH XEMIT CR
   \ debug:dump-stack
;


: expect-first-token  ( -- )
  tib @ begin dup c@ dup 0> swap bl <= and while 1+ repeat
  tok-addr <> " must be the first token in line" ?error
;

: token-eol?    ( -- bool )  tok-type tk-eos = ;
: token-colon?  ( -- bool )  tok-type tk-punct = tok-num [char] : = and ;
: token-comma?  ( -- bool )  tok-type tk-punct = tok-num [char] , = and ;
: token-lparen? ( -- bool )  tok-type tk-punct = tok-num [char] ( = and ;  ;; )
: token-rparen? ( -- bool )  tok-type tk-punct = tok-num [char] ) = and ;
: token-=?      ( -- bool )  tok-type tk-punct = tok-num [char] = = and ;
: token-str?    ( -- bool )  tok-type tk-str = ;
: token-id?     ( -- bool )  tok-type tk-id = ;
: token-num?    ( -- bool )  tok-type tk-num = ;

;; are we at end of line (real EOL, or ":")?
: token-colon-eol?  ( -- bool )  token-eol? token-colon? or ;

: token-resw?  ( -- bool ) tok-type tk-resw = ;
: token-uo?  ( uo -- bool ) tok-uo = token-resw? and ;
: token-uo-kind?  ( uo kind -- bool ) tok-kind = swap tok-uo = and token-resw? and ;

: token-regA?   ( -- bool )  asm-resw:uo-r8 asm-resw:kind-a token-uo-kind? ;
: token-regIR?  ( -- bool )  asm-resw:uo-sr8 token-uo? ;
: token-r8?     ( -- bool )  asm-resw:uo-r8 token-uo? ;
: token-rx8?    ( -- bool )  asm-resw:uo-rx8 token-uo? ;
: token-r16?    ( -- bool )  asm-resw:uo-r16 token-uo? ;
: token-af?     ( -- bool )  asm-resw:uo-r16 asm-resw:kind-af token-uo-kind? ;
: token-afx?    ( -- bool )  asm-resw:uo-afx token-uo? ;
: token-bc?     ( -- bool )  asm-resw:uo-r16 asm-resw:kind-bc token-uo-kind? ;
: token-de?     ( -- bool )  asm-resw:uo-r16 asm-resw:kind-de token-uo-kind? ;
: token-hl?     ( -- bool )  asm-resw:uo-r16 asm-resw:kind-hl token-uo-kind? ;
: token-sp?     ( -- bool )  asm-resw:uo-r16 asm-resw:kind-sp token-uo-kind? ;
: token-ix?     ( -- bool )  asm-resw:uo-rx16 asm-resw:kind-ix token-uo-kind? ;
: token-iy?     ( -- bool )  asm-resw:uo-rx16 asm-resw:kind-iy token-uo-kind? ;
: token-ixy?    ( -- bool )  asm-resw:uo-rx16 token-uo? ;
: token-mr16?   ( -- bool )  asm-resw:uo-mr16 token-uo? ;
: token-(hl)?   ( -- bool )  asm-resw:uo-r8 asm-resw:kind-(hl) token-uo-kind? ;
: token-(bc)?   ( -- bool )  asm-resw:uo-mr16 asm-resw:kind-bc token-uo-kind? ;
: token-(sp)?   ( -- bool )  asm-resw:uo-mr16 asm-resw:kind-sp token-uo-kind? ;
: token-(ixy)?  ( -- bool )  asm-resw:uo-mrx16 token-uo? ;
: token-(c)?    ( -- bool )  asm-resw:uo-portc token-uo? ;
: token-r16-n?  ( -- bool )  asm-resw:uo-r16 token-uo? tok-kind asm-resw:kind-sp <= and ;
: token-r16-x?  ( -- bool )  asm-resw:uo-r16 token-uo? tok-kind asm-resw:kind-hl <= and ;
: token-mr16-x? ( -- bool )  asm-resw:uo-mr16 token-uo? tok-kind asm-resw:kind-hl <= and ;
: token-reg-c?  ( -- bool )  asm-resw:uo-r8 asm-resw:kind-c token-uo-kind? ;
: token-equ?    ( -- bool ) asm-resw:uo-equ token-uo? ;
: token-(c)/(bc)?  ( -- bool )  token-(c)? token-(bc)? or ;

: token-(hl)->mr16  ( -- )
  token-(hl)? if asm-resw:uo-mr16 to tok-uo asm-resw:kind-hl to tok-kind endif
;

;; converts C register to condition
: token-c-to-cond  ( -- )
  token-reg-c? if
    asm-resw:uo-cond to tok-uo
    asm-resw:kind-cc to tok-kind
  endif
;

: token-cond? ( -- bool )
  token-reg-c? if token-c-to-cond true
  else asm-resw:uo-cond token-uo?
  endif
;


: (build-expector)  ( -- )  \ name checker msg|
  parse-name dup " name expected" ?not-error
  compiler:(create-forth-header) [compile] ]
  [compile] [compile]
  parse-skip-blanks [char] | parse " message expected" ?not-error strliteral
  compile ?not-error
;

: (build-expector-finish)  ( -- )
  compile next-token compile forth:(exit) [compile] [
  compiler:smudge
;

: build-expector:  ( -- )  \ name checker msg|
  (build-expector) (build-expector-finish)
;

: build-expector-res:  ( -- )  \ name checker msg|
  (build-expector) compile tok-kind (build-expector-finish)
;

build-expector: expect-eol      token-eol?       end of line expected|
build-expector: expect-str      token-str?       quoted string expected|
build-expector: expect-eop      token-colon-eol? end of line expected|
build-expector: expect-comma    token-comma?     comma expected|
build-expector: expect-lparen   token-lparen?    `(` expected|
build-expector: expect-rparen   token-rparen?    `)` expected|
build-expector: expect-regA     token-regA?      `A` register expected|
build-expector: expect-(c)      token-(c)?       `(C)` expected|
build-expector: expect-(c)/(bc) token-(c)/(bc)?  `(C)` expected|

build-expector-res: expect-cond  token-cond?  condition code expected|
build-expector-res: expect-r8    token-r8?    8-bit register expected|
build-expector-res: expect-r16   token-r16?   16-bit register expected|

prev-defs

\ debug:dump-stack