urflibs/urasm/main.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrAsm Forth Engine!
   4 ;; GPLv3 ONLY
   5 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; Z80 Assembler: main module
   7 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9
  10 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11 ;; DEFFMT directive
  12 ;;
  13
  14 enum{
  15   def: out-none
  16   def: out-sna48
  17   def: out-sna128
  18   def: out-raw
  19 }
  20
  21 out-sna48 value out-format
  22 false value out-locked
  23
  24 false value do-org-100
  25
  26 : .curr-file  ( -- )
  27   0 (include-file-name) xtype
  28 ;
  29
  30
  31 also asm-lexer
  32 also-defs: asm-instr
  33
  34 0 value ret-forth (hidden)
  35 0 value ret-forth-rp (hidden)
  36
  37 : (done-forth)  ( -- )
  38   ret-forth-rp 0 mtask:state-rp! rdrop
  39   ret-forth >r
  40 ; (hidden)
  41
  42 ..: forth:(interpret-check-word)  ( addr count FALSE -- addr count FALSE / TRUE )
  43   ret-forth if
  44     dup ifnot drop
  45       \ 2dup " $END-FORTH" string:=ci if (done-forth) endif
  46       2dup " $END_FORTH" string:=ci if (done-forth) endif
  47       false
  48     endif
  49   endif
  50 ;..
  51
  52 : (do-forth)  ( -- )
  53   r@ to ret-forth
  54   0 mtask:state-rp@ to ret-forth-rp
  55   interpret
  56 ; (hidden)
  57
  58 : $START_FORTH  ( -- )
  59   (do-forth) sp0!
  60   parse-skip-line next-token
  61 ;
  62
  63
  64 : DEFFMT  ( -- )
  65   next-token tok-type tk-id <> " identifier expected" ?error
  66   out-locked ifnot
  67     token " sna" string:=ci if out-sna48 to out-format next-token exit endif
  68     token " sna48" string:=ci if out-sna48 to out-format next-token exit endif
  69     token " sna128" string:=ci if out-sna128 to out-format next-token exit endif
  70     token " raw" string:=ci if out-raw to out-format next-token exit endif
  71     token " bin" string:=ci if out-raw to out-format next-token exit endif
  72     token " none" string:=ci if out-none to out-format next-token exit endif
  73     token " null" string:=ci if out-none to out-format next-token exit endif
  74     endcr ." unknown output format: " token xtype cr
  75     " unknown output format" error
  76   else next-token endif
  77 ;
  78 ALIAS DEFFMT $DEFFMT
  79
  80
  81 0 value dup-curr (hidden)
  82
  83 : dup->prev  ( addr -- addr )  ; immediate (hidden)
  84 : dup->count ( addr -- addr )  cell+ ; (hidden)
  85 : dup->line  ( addr -- addr )  2 +cells ; (hidden)
  86 : dup->fofs  ( addr -- addr )  3 +cells ; (hidden)
  87 4 cells constant dup-size (hidden)
  88
  89
  90 0 value inc-curr (hidden)
  91
  92 : inc->prev  ( addr -- addr )  ; immediate (hidden)
  93 : inc->dupr  ( addr -- addr )  cell+ ; (hidden)
  94 2 cells constant inc-size (hidden)
  95
  96 : (end-include)  ( -- eof-flag )
  97   inc-curr if
  98     dup-curr " unfinished DUP" ?error
  99     inc-curr inc->dupr @ to dup-curr
 100     inc-curr inc->prev @ to inc-curr
 101     next-token expect-eol
 102     refill drop next-token
 103     false
 104     ." continue >: " .curr-file cr
 105   else true endif
 106 ; (hidden)
 107
 108 : INCLUDE  ( -- )
 109   next-token tok-type tk-str <> " quoted file name expected" ?error
 110   token string:>pad next-token expect-eol
 111   inc-size n-allot
 112   inc-curr over inc->prev ! to inc-curr
 113   dup-curr inc-curr inc->dupr !
 114   0 to dup-curr
 115   string:pad-cc@ 0 0 (include-no-refill)
 116   ." included <: " .curr-file cr
 117   next-token expect-eol
 118 ;
 119 ALIAS INCLUDE $INCLUDE
 120
 121 : EDUP  ( -- )
 122   next-token expect-eol
 123   dup-curr " EDUP without DUP" ?not-error
 124   dup-curr dup->count @ 1- dup +if
 125     dup-curr dup->count !
 126     dup-curr dup->line @ 1- dup-curr dup->fofs @ (INCLUDE-LINE-SEEK)
 127     refill-nocross " wuta?" ?not-error parse-skip-line  ;; skip EDUP
 128     next-token expect-eol
 129   else drop dup-curr dup->prev @ to dup-curr endif
 130 ;
 131
 132 ;;WARNING! THIS MUST BE THE LAST ONE!
 133 : DUP  ( -- )
 134   next-token asm-expr:expression-const expect-eol
 135   dup 1 65536 within " invalid DUP counter" ?not-error
 136   dup-size n-allot
 137   dup-curr over dup->prev ! to dup-curr
 138   dup-curr dup->count !
 139   0 (INCLUDE-FILE-LINE) dup-curr dup->line !
 140   (INCLUDE-LINE-FOFS) dup-curr dup->fofs !
 141 ;
 142
 143 ;;WARNING! THOSE MUST BE THE LATEST ONES!
 144 : else  " please, use $ELSE" asm-lexer:warning $ELSE ;
 145 : if  " please, use $IF" asm-lexer:warning $IF ;
 146 : elsif  " please, use $ELSIF" asm-lexer:warning $ELSIF ;
 147 : elif  " please, use $ELSIF" error ;
 148 : endif  " please, use $ENDIF" asm-lexer:warning $ENDIF ;
 149
 150 previous prev-defs
 151
 152
 153
 154 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 155 ;; main assembler loop
 156 ;;
 157
 158 also asm-lexer
 159
 160 : assemble-token-punct  ( -- )
 161   token-colon? ifnot dump-token " bad syntax" error endif
 162   next-token
 163   asm-labels:clear-last-defined-label
 164 ;
 165
 166 : assemble-token-label  ( as-label? -- )
 167   >r  ;; save "as-label?"
 168   token asm-helpers:find-struct if
 169     tok-label-colon? " declare structs without a colon, please" ?error
 170     asm-helpers:declare-anon-struct
 171   else
 172     string:>pad next-token string:pad-cc@
 173     case
 174       token-equ? if-of asm-equ endof
 175       token-=? if-of asm-ass endof
 176       token-id? if-of 2drop
 177           token asm-helpers:find-struct if asm-helpers:declare-labeled-struct
 178           else
 179             string:pad-cc@ r@ ifnot
 180               endcr space xtype ." ? wut?" cr
 181               " dunno what to do" error
 182             endif
 183             asm-emit:pc$ asm-labels:define-code
 184           endif
 185         endof
 186       otherwise 2drop
 187         string:pad-cc@ r@ ifnot
 188           endcr space xtype ." ? wut?" cr
 189           " dunno what to do" error
 190         endif
 191         asm-emit:pc$ asm-labels:define-code
 192     endcase
 193   endif rdrop
 194 ;
 195
 196 : assemble-token-mnemo  ( -- )
 197   tok-mnemo-cfa execute
 198   token-colon-eol? " end of instruction expected" ?not-error
 199   asm-labels:clear-last-defined-label
 200 ;
 201
 202 : assemble-file  ( addr count -- )
 203   dup +if false false (include) else 2drop endif
 204   true to line-start next-token
 205   ." assembling: " .curr-file cr
 206   get-msecs >r
 207   begin
 208     begin
 209       tok-type tk-eos =
 210     while
 211       \ ." *** NEWLINE ***: " 0 (INCLUDE-FILE-NAME) xtype 0 (INCLUDE-FILE-LINE) space . cr
 212       refill-nocross ifnot break endif
 213       true to line-start
 214       $IF 0
 215         ." <" (tib-in) 0 begin dup tib-peekch-ofs while 1+ repeat xtype ." >" cr
 216       $ENDIF
 217       true to line-start next-token
 218     repeat
 219     asm-emit:instruction-start
 220     $IF 0
 221       dump-token
 222     $ENDIF
 223     tok-type case
 224       tk-eos of
 225           asm-labels:clear-last-defined-label
 226           asm-instr:(end-include)
 227           if break endif
 228         endof
 229       tk-punct of assemble-token-punct endof
 230       tk-label of true assemble-token-label endof
 231       tk-id of false assemble-token-label endof  ;; this can be " lbl = ..." or " lbl equ ..."
 232       tk-mnemo of assemble-token-mnemo endof
 233       otherwise dump-token " wutafuck?" error
 234     endcase
 235     depth " ASSEMBLER: unbalanced stack" ?error
 236   again
 237   get-msecs r> - ." assembled in " . ." msecs." cr
 238 ;
 239
 240 previous
 241
 242
 243 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 244 ;; utilities
 245 ;;
 246
 247 : write-sna  ( addr count wr-cfa -- )
 248   >r
 249   string:>pad string:pad-remove-ext " .sna" string:pad+cc
 250   ." OUTPUT: " string:pad-cc@ xtype cr
 251   string:pad-cc@ files:create " cannot create output .SNA" ?not-error
 252   dup r> execute
 253   files:close drop
 254 ;
 255
 256
 257 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 258 ;; main entry point
 259 ;;
 260
 261 0 value arg-idx
 262 -1 value arg-fname-idx
 263
 264 : next-arg  ( -- )  +1-to arg-idx ;
 265
 266 vocabulary cli-args
 267 also-defs: cli-args
 268
 269 : --raw  ( -- )  out-raw to out-format true to out-locked next-arg ;
 270 : --sna  ( -- )  out-sna48 to out-format true to out-locked next-arg ;
 271 alias --sna --sna48
 272 : --sna128  ( -- )  out-sna128 to out-format true to out-locked next-arg ;
 273 : --none  ( -- )  out-none to out-format true to out-locked next-arg ;
 274 : --org100h  ( -- )  true to do-org-100 next-arg ;
 275
 276 : --reffile  ( -- )  next-arg ;
 277
 278 prev-defs
 279
 280 : parse-arg  ( -- )
 281   arg-idx argv dup if
 282     vocid: cli-args find-word-in-voc if
 283       execute
 284     else
 285       arg-fname-idx 0>= " too many file names" ?error
 286       arg-idx to arg-fname-idx
 287       next-arg
 288     endif
 289   else 2drop next-arg endif
 290 ;
 291
 292
 293 : RUN-URASM  ( -- )
 294   begin arg-idx argc < while parse-arg repeat
 295   do-org-100 if 0x100
 296     dup to asm-emit:pc dup to asm-emit:emit-pc
 297     dup to asm-emit:ent 1- to asm-emit:clr
 298   endif
 299   arg-fname-idx 0< if
 300     " ." false false (include)
 301     \ " assemble what?" ?error
 302     0 0
 303   else arg-fname-idx argv endif
 304   assemble-file
 305   \ asm-labels:dump-labels
 306   asm-labels:check-labels
 307   out-format case
 308     out-none of endof
 309     out-sna48 of arg-fname-idx argv ['] asm-writers:write-sna-48 write-sna endof
 310     out-sna128 of arg-fname-idx argv ['] asm-writers:write-sna-128 write-sna endof
 311     out-raw of arg-fname-idx argv asm-writers:write-raw endof
 312     otherwise " internal error: bad output format" error
 313   endcase
 314 ;