urflibs/urasm/expr.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrAsm Forth Engine!
   4 ;; GPLv3 ONLY
   5 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; Z80 Assembler: expression parser
   7 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9 (*
  10   expression evaluator is done as a compiler to Forth code.
  11   any math expression is compiled to executable Forth code. on executing,
  12   this code creates label references, and THROWs on undefined label.
  13 *)
  14
  15
  16 vocab-if-none asm-expr
  17
  18 also asm-lexer
  19 also-defs: asm-expr
  20
  21 vocab-if-none asm-funcs
  22
  23
  24 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25 ;; error codes for "throw"
  26 ;;
  27
  28 0 value err-label-c1str
  29
  30 1 enum-from{
  31   def: error-undefined-label
  32   def: error-division-by-0
  33   def: error-invalid-shift
  34 }
  35
  36 : error-undefined-label? ( code -- bool )  error-undefined-label = ;
  37
  38 : error-message ( code -- addr count )
  39   case
  40     error-undefined-label of " undefined label" endof
  41     error-division-by-0 of " division by 0" endof
  42     error-invalid-shift of " invalid shift" endof
  43     otherwise drop " unknown error"
  44   endcase
  45 ;
  46
  47
  48 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49 ;; generate code for expression evaluation (low level)
  50 ;;
  51
  52 ;; hack: patch branch
  53 : (run-forth-at-addr)  ( ... addr -- ... )
  54   [ ' forth:(lit) , here 0 , ] compiler:(branch-addr!)
  55   [ ' forth:(branch) , here 0 , swap ! ]
  56 ;
  57
  58 \ debug:decompile (run-forth-at-addr)
  59
  60 -1 value bc-buffer-start
  61 -1 value bc-buffer-end
  62
  63 ;; this references label only once
  64 ;; uses self-modifying code
  65 : (ref-label)  ( addr count -- addr count )
  66   2dup r> dup @  ( addr count ip refed? )
  67   if nrot 2drop
  68   else nrot asm-labels:ref true over !
  69   endif cell+ >r
  70 ; compiler:(warg-lit) compiler:set-warg
  71
  72 ;; compiled to generated expression code
  73 : (get-label)  ( addr count -- value )
  74   asm-labels:get ifnot error-undefined-label throw
  75   else ( ." LABEL: " dup . cr )
  76   endif
  77 ;
  78
  79 : (div)  ( a b -- )  dup ifnot error-division-by-0 throw endif / ;
  80 : (mod)  ( a b -- )  dup ifnot error-division-by-0 throw endif mod ;
  81
  82 : (sal)  ( a count -- )
  83   0 32 within ifnot error-invalid-shift throw endif
  84   ash
  85 ;
  86
  87 : (sar)  ( a count -- )
  88   0 32 within ifnot error-invalid-shift throw endif
  89   negate ash
  90 ;
  91
  92
  93 : bc-init  ( -- )  here to bc-buffer-start ;
  94
  95 : bc-undo-all  ( -- )
  96   bc-buffer-start 0< " cannot undo bc -- nothing to do" ?error
  97   bc-buffer-start forth:(dp) !
  98   -1 to bc-buffer-start
  99 ;
 100
 101 ;; throw on error
 102 : bc-run  ( addr -- result TRUE / errorcode FALSE )
 103   ['] (run-forth-at-addr) catch ?dup if nip ( drop `addr` ) false
 104   else true endif
 105 ;
 106
 107 : bc-do-as-compiler:  ( cfa -- )  \ name word
 108   create parse-skip-comments -find-required ,
 109  does> ( pfa )
 110   state @ >r state 1!  @execute  r> state !
 111 ;
 112
 113 bc-do-as-compiler: bc-,            ( n -- )   forth:,
 114 bc-do-as-compiler: bc-compile,     ( cfa -- ) compile,
 115 bc-do-as-compiler: bc-compile      ( -- )     compile  immediate
 116 bc-do-as-compiler: bc-emit-lit     ( n -- )   literal
 117 bc-do-as-compiler: bc-emit-strlit  ( n -- )   strliteral
 118
 119 : bc-emit-label  ( addr count -- )
 120   2dup 1 = swap c@ [char] $ = and if
 121     2drop asm-emit:pc$ bc-emit-lit
 122   else
 123     asm-labels:fix-prefix bc-emit-strlit
 124     bc-compile (ref-label) false bc-,
 125     bc-compile (get-label)
 126   endif
 127 ;
 128
 129
 130 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 131 ;; generate code for expression evaluation (parser)
 132 ;;
 133
 134 defer (parse-expr)
 135
 136
 137 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 138 ;; terminal and unaries
 139 ;;
 140
 141 : term  ( -- )
 142   tok-type case
 143     tk-num of tok-num bc-emit-lit next-token endof
 144     tk-id of  ;; label or function
 145         token vocid: asm-funcs find-word-in-voc  ( cfa TRUE / FALSE )
 146         if next-token execute
 147         else token bc-emit-label next-token
 148         endif
 149       endof
 150     tk-str of
 151         tok-num 0< " unexpected string" ?error
 152         tok-num bc-emit-lit next-token
 153       endof
 154     otherwise
 155       endcr space token xtype ." ? -- wut?" cr " unknown term" error
 156   endcase
 157 ;
 158
 159 : unary  ( -- )
 160   tok-type tk-punct = if
 161     tok-num case
 162       [char] ( of  ;; )
 163           next-token (parse-expr)
 164           tok-type tk-punct =  tok-num [char] ) = and " unbalanced parens" ?not-error
 165           next-token
 166         endof
 167       [char] ! of
 168           next-token recurse
 169           bc-compile not
 170         endof
 171       [char] ~ of
 172           next-token recurse
 173           bc-compile bitnot
 174         endof
 175       [char] + of
 176           next-token recurse
 177         endof
 178       [char] - of
 179           next-token recurse
 180           bc-compile negate
 181         endof
 182       otherwise " invalid expression (term expected)" error
 183     endcase
 184   else term
 185   endif
 186 ;
 187
 188
 189 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 190 ;; define binary operators table
 191 ;;
 192
 193 : def-op  ( prio -- prio )  \ token doer
 194   dup ,  ;; priority
 195   parse-name dup 1 2 bounds? " invalid token" ?not-error
 196   1 = if c@ else w@ endif ,  ;; put token code
 197   -find-required ,  ;; doer CFA
 198 ;
 199
 200 : -next-prio-  ( prio -- prio+1 )  1+ ;
 201
 202 1  ;; current priority
 203 create operators
 204  -next-prio- dup
 205   def-op  * forth:*
 206   def-op  / (div)
 207   def-op  % (mod)
 208  -next-prio-
 209   def-op  + forth:+
 210   def-op  - forth:-
 211  -next-prio-
 212   def-op << (sal)
 213   def-op >> (sar)
 214  -next-prio-
 215   def-op  < forth:<
 216   def-op <= forth:<=
 217   def-op  > forth:>
 218   def-op >= forth:>=
 219  -next-prio-
 220   def-op  = forth:=
 221   def-op == forth:-
 222   def-op <> forth:<>
 223   def-op != forth:<>
 224  -next-prio-
 225   def-op  & forth:and
 226  -next-prio-
 227   def-op  ^ forth:xor
 228  -next-prio-
 229   def-op  | forth:or
 230  -next-prio-
 231   def-op && forth:(0branch)
 232  -next-prio-
 233   def-op || forth:(tbranch)
 234   0 ,  ;; no more
 235 create;
 236 constant max-prio
 237 constant min-binary-prio
 238 \ min-binary-prio 2 <> " shit!" ?error
 239
 240
 241 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 242 ;; table-driven expression parser
 243 ;;
 244
 245 : (xbranch?)  ( opc -- bool )
 246   dup ['] forth:(0branch) =  swap ['] forth:(tbranch) = or
 247 ;
 248
 249 ;; find operator using the given priority and the current token
 250 : (find-operator)  ( prio -- opcode TRUE / FALSE )
 251   tok-type tk-punct = if
 252     >r operators
 253     begin
 254       dup @ r@ = if
 255         dup cell+ @ tok-num = if
 256           rdrop 2 +cells @ true exit
 257         endif
 258       endif
 259       3 +cells
 260       dup @
 261     not-until rdrop
 262   endif
 263   drop false
 264 ;
 265
 266 : (expr)  ( prio -- )
 267   dup min-binary-prio < if drop unary
 268   else  ( prio )
 269     dup 1- recurse  ;; left operand
 270     ( prio )
 271     0 >r ;; save jump chain start to rstack for short-circuit logicals
 272     begin
 273       dup (find-operator)
 274     while
 275       next-token  ;; skip operator
 276       dup (xbranch?) if
 277         ;; logic op: jump over the following code
 278         bc-compile dup
 279         bc-compile, r> compiler:(chain-j>) >r
 280         bc-compile drop
 281         dup 1- recurse
 282       else
 283         over 1- recurse bc-compile,
 284       endif
 285     repeat drop
 286     r> compiler:(resolve-j>)
 287   endif
 288 ;
 289
 290 :noname  ( -- )
 291   max-prio (expr)
 292 ; to (parse-expr)
 293
 294
 295 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 296 ;; high-level API
 297 ;;
 298
 299 : (setup-lexer)  ( -- )
 300   false to asm-lexer:line-start
 301 ;
 302
 303 : (restore-lexer)  ( -- )
 304 ;
 305
 306 ;; reset expression code buffer to HERE, parse expression, generate code
 307 : expression  ( -- )
 308   (setup-lexer)
 309   bc-init (parse-expr) bc-compile forth:(exit)
 310   here to bc-buffer-end
 311   (restore-lexer)
 312 ;
 313
 314
 315 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 316 ;; expression range checkers
 317 ;;
 318
 319 : (expr-check-byte)  ( value -- )  -128 256 within " 8-bit value out of range" ?not-error ;
 320 : (expr-check-addr)  ( value -- )  0 65536 within " address out of range" ?not-error ;
 321 : (expr-check-ubyte) ( value -- )  0 256 within " unsigned 8-bit value out of range" ?not-error ;
 322 : (expr-check-word)  ( value -- )  -32768 65536 within " 16-bit value out of range" ?not-error ;
 323 : (expr-check-im)    ( value -- )  0 3 within " invalid IM number" ?not-error ;
 324 : (expr-check-rel8)  ( value -- )  -128 128 within " relative jump too long" ?not-error ;
 325 : (expr-check-bit)   ( value -- )  0 8 within " invalid bit number" ?not-error ;
 326 : (expr-check-disp+) ( value -- )  -128 128 within " displacement out of range" ?not-error ;
 327 : (expr-check-disp-) ( value -- )  negate -128 128 within " displacement out of range" ?not-error ;
 328 : (expr-check-rst)   ( value -- )  dup 0 0x38 bounds?  swap 0x03 and 0=  and  " invalid RST address" ?not-error ;
 329
 330
 331 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 332 ;; fixers for postponed expressions
 333 ;;
 334
 335 also asm-labels
 336
 337 : fix-addr  ( -- )
 338   fix-value dup (expr-check-addr)
 339   fix-disp asm-emit:w!
 340 ;
 341
 342 : fix-word  ( -- )
 343   fix-value dup (expr-check-word)
 344   fix-disp asm-emit:w!
 345 ;
 346
 347 : fix-rword  ( -- )
 348   fix-value dup (expr-check-word)
 349   fix-disp asm-emit:rw!
 350 ;
 351
 352 : fix-byte  ( -- )
 353   fix-value dup (expr-check-byte)
 354   fix-disp asm-emit:c!
 355 ;
 356
 357 : fix-ubyte  ( -- )
 358   fix-value dup (expr-check-ubyte)
 359   fix-disp asm-emit:c!
 360 ;
 361
 362 : fix-disp+  ( -- )
 363   fix-value dup (expr-check-disp+)
 364   fix-disp asm-emit:c!
 365 ;
 366
 367 : fix-disp-  ( -- )
 368   fix-value negate dup (expr-check-disp+)
 369   fix-disp asm-emit:c!
 370 ;
 371
 372 : fix-rel8  ( -- )
 373   fix-value fix-pc 1+ - dup (expr-check-rel8)
 374   fix-disp asm-emit:c!
 375 ;
 376
 377 : fix-im  ( -- )
 378   fix-value dup (expr-check-im)
 379   asm-emit:(im) fix-disp asm-emit:c!
 380 ;
 381
 382 : fix-rst  ( -- )
 383   fix-value dup (expr-check-rst)
 384   fix-disp asm-emit:rst-c!
 385 ;
 386
 387 : fix-bit  ( -- )
 388   fix-value dup (expr-check-bit)
 389   fix-disp asm-emit:bit-c!
 390 ;
 391
 392 : put-bit  ( value -- )
 393   asm-emit:here asm-emit:bit-c!
 394 ;
 395
 396 : put-ent  ( value -- )  to asm-emit:ent ;
 397 : fix-ent  ( -- )  fix-value dup (expr-check-addr) put-ent ;
 398
 399 : put-clr  ( value -- )  to asm-emit:clr ;
 400 : fix-clr  ( -- )  fix-value dup (expr-check-addr) put-clr ;
 401
 402
 403 previous
 404
 405
 406 : (save-expr)  ( fixer-cfa -- )
 407   ( fix-addr fix-disp fixer-cfa expr-cfa -- )
 408   asm-emit:emit-pc asm-emit:pc rot bc-buffer-start
 409   asm-labels:remember-expr
 410 ;
 411
 412 : (expr-do,)  ( cfa-check cfa-emit cfa-fix -- )
 413     bc-buffer-start bc-run if  ( cfa-check cfa-emit cfa-fix value )
 414       >r rot r@ swap execute
 415       drop r> swap execute-tail
 416     else  ( cfa-check cfa-emit cfa-fix error )
 417       dup error-undefined-label? if drop (save-expr) 0 swap execute drop
 418       else error-message error
 419       endif
 420     endif
 421 ;
 422
 423 ;; expression already parsed
 424 : expression-addr-postponed,  ( -- )
 425   ['] (expr-check-addr)  ['] asm-emit:addr  ['] fix-addr
 426   (expr-do,)
 427 ;
 428
 429 : expression-addr,  ( -- )
 430   expression expression-addr-postponed,
 431 ;
 432
 433 : expression-addr-rel8,  ( -- )
 434   expression
 435   bc-buffer-start bc-run if  ( value )
 436     asm-emit:pc 1+ -
 437     dup (expr-check-rel8)
 438     asm-emit:byte
 439   else
 440     dup error-undefined-label? if drop
 441       ['] fix-rel8 (save-expr)
 442       0 asm-emit:byte
 443     else error-message error
 444     endif
 445   endif
 446 ;
 447
 448
 449 : expression-byte,  ( -- )  expression
 450   ['] (expr-check-byte)  ['] asm-emit:byte  ['] fix-byte
 451   (expr-do,)
 452 ;
 453
 454 : expression-ubyte,  ( -- )  expression
 455   ['] (expr-check-byte)  ['] asm-emit:byte  ['] fix-ubyte
 456   (expr-do,)
 457 ;
 458
 459 : expression-word,  ( -- )  expression
 460   ['] (expr-check-word)  ['] asm-emit:word  ['] fix-word
 461   (expr-do,)
 462 ;
 463
 464 : expression-rword,  ( -- )  expression
 465   ['] (expr-check-word)  ['] asm-emit:rword  ['] fix-rword
 466   (expr-do,)
 467 ;
 468
 469 : expression-disp+,  ( -- )  expression
 470   ['] (expr-check-disp+)  ['] asm-emit:byte  ['] fix-disp+
 471   (expr-do,)
 472 ;
 473
 474 : expression-disp-,  ( -- )  expression
 475   ['] (expr-check-disp-)  ['] asm-emit:neg-byte  ['] fix-disp-
 476   (expr-do,)
 477 ;
 478
 479 : expression-disp,  ( add-flag -- )
 480   if expression-disp+, else expression-disp-, endif
 481 ;
 482
 483 : expression-rst,  ( -- addr )  expression
 484   ['] (expr-check-rst)  ['] asm-emit:rst  ['] fix-rst
 485   (expr-do,)
 486 ;
 487
 488
 489 : expression-im,  ( -- idx )  expression
 490   ['] (expr-check-im)  ['] asm-emit:im  ['] fix-im
 491   (expr-do,)
 492 ;
 493
 494
 495 0 value bit-expr-addr
 496
 497 : expression-bit-postponed,  ( opc-base -- )
 498   asm-emit:byte
 499   bit-expr-addr to bc-buffer-start
 500   ['] (expr-check-bit)  ['] put-bit  ['] fix-bit
 501   (expr-do,)
 502 ;
 503
 504 : expression-bit  ( opc-base -- )  expression bc-buffer-start to bit-expr-addr ;
 505
 506
 507 : expression-ent  ( -- )  expression
 508   ['] (expr-check-addr)  ['] put-ent  ['] fix-ent
 509   (expr-do,)
 510 ;
 511
 512 : expression-clr  ( -- )  expression
 513   ['] (expr-check-addr)  ['] put-clr  ['] fix-clr
 514   (expr-do,)
 515 ;
 516
 517
 518 ' bc-run to asm-labels:(eval-expr-cfa)
 519 ' error-undefined-label? to asm-labels:(err-undefined?)
 520 ' error-message to asm-labels:(err-message)
 521
 522
 523 ;; expression value must be defined here
 524 : expression-const  ( -- value )
 525   expression
 526   bc-buffer-start bc-run ifnot error-message error endif
 527 ;
 528
 529
 530 previous prev-defs
 531
 532 \ debug:dump-stack
 533
 534 $IF 0
 535 : expr-test ( -- )  \ expr
 536   false to asm-lexer:line-start
 537   asm-lexer:next-token
 538   asm-expr:expression
 539   asm-expr:bc-buffer-start asm-expr:bc-buffer-end debug:(decompile-mem)
 540   asm-expr:bc-buffer-start asm-expr:bc-run
 541   asm-expr:bc-undo-all
 542   if
 543     ." result: " . cr
 544   else
 545     ." error: " dup . asm-expr:error-message ." (" type ." )" cr
 546   endif
 547 ;
 548
 549
 550 expr-test 3+4*2 || 5+label && (9+1)*2
 551 expr-test 3 || 2 + $
 552 expr-test 5 / 0
 553
 554 debug:dump-stack
 555 bye
 556 $ENDIF