level1/71_compiler_if_begin_do.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 voc-set-active COMPILER
   8
   9 ;; CSP check for loops
  10 : ?CSP-LOOP  ( -- )
  11   sp@ (csp) @ u> err-unpaired-conditionals ?error
  12 ;
  13
  14 : ?PAIRS  ( n1 n2 -- )
  15   <> err-unpaired-conditionals ?error
  16 ;
  17
  18
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20 : ?ANY-PAIR  ( id v0 v1 -- )
  21   >r over <>
  22   swap r> <>
  23   and err-unpaired-conditionals ?error
  24 ;
  25
  26 : ?PAIRS-ANY-KEEPID  ( id v0 v1 -- id )
  27   >r over <>  ;; ( id v0<>id | v1 )
  28   over r> <>  ;; ( id v0<>id v1<>id )
  29   and err-unpaired-conditionals ?error
  30 ;
  31
  32
  33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34 ;; usage:
  35 ;;  compile 0branch
  36 ;;  (mark>)
  37 ;;  ...
  38 ;;  (resolve>)
  39 ;;
  40 ;;  (<mark)
  41 ;;  ...
  42 ;;  compile branch
  43 ;;  (<resolve)
  44
  45 ;; write "branch to destaddr" address to addr
  46 ;; : (BRANCH-ADDR!)  ( destaddr addr -- )  !  ; (hidden)
  47 alias ! (BRANCH-ADDR!)
  48 (hidden)
  49
  50 ;; read branch address
  51 alias @ (BRANCH-ADDR@)  ( addr -- dest )
  52 (hidden)
  53
  54
  55 ;; reserve room for branch address, return addr suitable for "(RESOLVE-J>)"
  56 : (MARK-J>)  ( -- addr )
  57   here 0 ,
  58 ; (hidden)
  59
  60 ;; compile "forward jump" from address to HERE
  61 ;; addr is the result of "(MARK-J>)"
  62 : (RESOLVE-J>)  ( addr -- )
  63   here swap (branch-addr!)
  64 ; (hidden)
  65
  66
  67 ;; return addr suitable for "(<J-RESOLVE)"
  68 : (<J-MARK)  ( -- addr )
  69   here
  70 ; (hidden)
  71
  72 ;; patch "forward jump" address to HERE
  73 ;; addr is the result of "(<J-MARK)"
  74 : (<J-RESOLVE)  ( addr -- )
  75   cell n-allot (branch-addr!)
  76 ; (hidden)
  77
  78
  79 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  80 ;; yeah, the kernel has its own implementations, so we can load this in runtime
  81
  82 ;; each of these has one argument
  83 enum{
  84   1 set
  85   value (CTLID-IF)  (hidden)
  86   value (CTLID-ELSE)  (hidden)
  87
  88   value (CTLID-BEGIN)  (hidden)
  89   value (CTLID-WHILE)  (hidden)
  90
  91   value (CTLID-CASE)  (hidden)
  92   value (CTLID-OF)  (hidden)
  93   value (CTLID-ENDOF)  (hidden)
  94   value (CTLID-OTHERWISE)  (hidden)
  95
  96   value (CTLID-DO)  (hidden)
  97   value (CTLID-DO-BREAK)  (hidden)
  98   value (CTLID-DO-CONTINUE)  (hidden)
  99
 100   value (CTLID-CBLOCK)  (hidden)
 101   value (CTLID-CBLOCK-INTERP)  (hidden)
 102
 103   value (CTLID-?DO)  (hidden)
 104
 105   666 +set
 106   value (CTLID-SC-COLON)  (hidden)
 107
 108   42 +set
 109   value (XX-CTLID-LAST)  (hidden)
 110 }
 111
 112 (XX-CTLID-LAST) var (XX-CTLID-NEXT-USER)  (hidden)
 113
 114 : allocate-ctlid  ( -- id )  (xx-ctlid-next-user) @ (xx-ctlid-next-user) 1+! ;
 115
 116
 117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 118
 119 ;; there might be alot of "while" blocks, pop them all
 120 ;; compile jump back to begin
 121 : (END-BEGIN)  ( pairs... jumpcfa -- )
 122   ;; this is done recursively, because this way i can get rid of `par_resolve_jfwd_over_branch`
 123   ;; also, we don't have working loops at this point, so recursion is the only choice ;-)
 124   ?csp-loop
 125   over (CTLID-BEGIN) = if
 126     compile,
 127     (CTLID-BEGIN) ?pairs
 128     (<j-resolve)
 129   else
 130     swap
 131     (CTLID-WHILE) ?pairs
 132     swap >r recurse r>
 133     (resolve-j>)
 134   endif
 135 ; (hidden)
 136
 137 : (COMP-WHILE)  ( jumpcfa )
 138   ?comp
 139   >r (CTLID-BEGIN) (CTLID-WHILE) ?pairs-any-keepid r>
 140   compile,
 141   (mark-j>)
 142   (CTLID-WHILE)
 143 ; (hidden)
 144
 145
 146 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 147 ;; alas, i had to use one global var
 148 ;; <>0: drop when we'll see CASE
 149 ;; set to 0 by (CTLID-OF) or (CTLID-OTHERWISE)
 150 $value "(B/C-CASE-DROP)" 0
 151 (hidden)
 152
 153 ;; workhorse for break/continue
 154 ;; type:
 155 ;;   0: break
 156 ;;   1: continue
 157 : (BREAK/CONTINUE)  ( type )
 158   ?comp
 159   0 2>r  ;; type and counter
 160   ;; drop on case by default
 161   1 to (b/c-case-drop)
 162   begin
 163     ?csp-loop
 164     ;; check for valid ctlid
 165     dup (CTLID-DO-CONTINUE) > over (CTLID-IF) < or ERR-INVALID-BREAK-CONT ?error
 166     ;; while not begin and not do
 167     dup (CTLID-BEGIN) = over (CTLID-DO) = or not
 168   while
 169     ;; move to rstack
 170       ;; DEBUG
 171       ;; 2dup pardottype "SAVE: ctlid: " dot  pardottype " addr: " udot cr
 172     ;; process case:
 173     ;;   if we're in (CTLID-CASE) or in (CTLID-ENDOF), compile DROP
 174     dup (CTLID-CASE) = if
 175       (b/c-case-drop) if
 176           ;; DEBUG
 177           ;; pardottype " compiling DROP (" dup dot pardottype ")" cr
 178         compile drop
 179       endif
 180       ;; drop on next case by default
 181       1 to (b/c-case-drop)
 182     endif
 183     dup (CTLID-OF) = over (CTLID-OTHERWISE) = or
 184     if 0 to (b/c-case-drop) endif  ;; don't drop on next case by default
 185     2r> 2swap >r >r 2+ 2>r
 186   repeat
 187   ;; return stack contains saved values and counter
 188   dup (CTLID-DO) = if
 189     ;; do...loop
 190     ;; check type
 191     1 rpick  ;; peek the type
 192     if
 193         ;; DEBUG
 194         ;; pardottype "DO/LOOP: continue" cr
 195       ;; coninue: jump to (LOOP)
 196       compile branch
 197       (mark-j>)
 198       (CTLID-DO-CONTINUE)
 199     else
 200       ;; break: drop do args, jump over (LOOP)
 201         ;; DEBUG
 202         ;; pardottype "DO/LOOP: break" cr
 203       compile unloop  ;; remove do args
 204       compile branch
 205       (mark-j>)
 206       (CTLID-DO-BREAK)
 207     endif
 208   else
 209     (CTLID-BEGIN) ?pairs
 210     ;; check type
 211     1 rpick  ;; i.e. peek the type
 212     if
 213       ;; coninue
 214         ;; DEBUG
 215         ;; pardottype "BEGIN: continue" cr
 216       dup            ;; we still need the address
 217       compile branch
 218       (<j-resolve)
 219       (CTLID-BEGIN)    ;; restore ctlid
 220     else
 221       ;; break
 222         ;; DEBUG
 223         ;; pardottype "BEGIN: break" cr
 224       (CTLID-BEGIN)    ;; restore ctlid
 225       compile branch
 226       (mark-j>)
 227       (CTLID-WHILE)
 228     endif
 229   endif
 230
 231   ;; move saved values back to the data stack
 232   r> rdrop  ;; drop type
 233     ;; DEBUG
 234     ;; dup pardottype "RESTORE " dot pardottype "items" cr
 235   begin ?dup while r> swap 1- repeat
 236     ;; DEBUG
 237     ;; dup . over udot cr
 238 ; (hidden)
 239
 240
 241 : (END-LOOP)  ( endloopcfa )
 242   ;; this is done recursively, because this way i can get rid of `par_resolve_jfwd_over_branch`
 243   ?csp-loop
 244   over (CTLID-DO) = if
 245     compile,
 246     (CTLID-DO) ?pairs
 247     (<j-resolve)
 248     ;; resolve ?DO jump, if it is there
 249     dup (CTLID-?DO) = if drop (resolve-j>) endif
 250   else
 251     ;; "continue" should be compiled before recursion, and "break" after it
 252     swap
 253     dup (CTLID-DO-CONTINUE) = if
 254       ;; patch "continue" branch
 255       (CTLID-DO-CONTINUE) ?pairs
 256       swap (resolve-j>)
 257       recurse
 258     else
 259       (CTLID-DO-BREAK) ?pairs
 260       swap >r recurse r>
 261       ;; here, loop branch already compiled
 262       (resolve-j>)
 263     endif
 264   endif
 265 ; (hidden)
 266
 267
 268 : (X-OF)  ( ... word-to-compare )
 269   ?comp
 270   >r  ;; save XOF args
 271   (CTLID-CASE) (CTLID-ENDOF) ?pairs-any-keepid   ;; we should be in normal CASE
 272   \ compile over  ;; special compare words will do this for us
 273   r> compile,  ;; comparator
 274   compile 0branch-drop
 275   (mark-j>)
 276   (CTLID-OF)
 277 ; (hidden)
 278
 279 : (END-CASE)
 280   dup (CTLID-OTHERWISE) = if
 281     ;; "otherwise", no drop needed
 282     (CTLID-OTHERWISE) ?pairs
 283     0 ?pairs  ;; check dummy argument
 284   else
 285     ;; no "otherwise", compile DROP
 286     compile drop
 287   endif
 288   ;; patch branches
 289   begin
 290     ?csp-loop
 291     dup (CTLID-CASE) <>
 292   while
 293     (CTLID-ENDOF) ?pairs
 294     (resolve-j>)
 295   repeat
 296   (CTLID-CASE) ?pairs
 297   0 ?pairs  ;; check dummy argument
 298 ;
 299
 300
 301 voc-set-active FORTH
 302
 303
 304 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 305 : IF
 306   compiler:?comp
 307   compile 0branch
 308   compiler:(mark-j>)
 309   compiler:(CTLID-IF)
 310 ; immediate
 311
 312 : IFNOT
 313   compiler:?comp
 314   compile tbranch
 315   compiler:(mark-j>)
 316   compiler:(CTLID-IF)
 317 ; immediate
 318
 319 ;; if negative (not zero)
 320 : -IF
 321   compiler:?comp
 322   compile +0branch
 323   compiler:(mark-j>)
 324   compiler:(CTLID-IF)
 325 ; immediate
 326
 327 ;; if positive (not zero)
 328 : +IF
 329   compiler:?comp
 330   compile -0branch
 331   compiler:(mark-j>)
 332   compiler:(CTLID-IF)
 333 ; immediate
 334
 335 : ELSE
 336   compiler:?comp compiler:(CTLID-IF) compiler:?pairs
 337   compile branch
 338   compiler:(mark-j>)
 339   swap compiler:(resolve-j>)
 340   compiler:(CTLID-ELSE)
 341 ; immediate
 342
 343 : ENDIF
 344   compiler:?comp
 345   compiler:(CTLID-IF) compiler:(CTLID-ELSE) compiler:?any-pair
 346   compiler:(resolve-j>)
 347 ; immediate
 348
 349 alias endif then
 350
 351
 352 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 353 ;;
 354 ;; you can use as many "while" blocks as you want to
 355 ;; any loop can be finished with AGAIN/REPEAT/UNTIL
 356 ;; "BREAK" and "CONTINUE" cannot be used inside conditionals yet
 357 ;;
 358
 359 : BEGIN
 360   compiler:?comp
 361   compiler:(<j-mark)
 362   compiler:(CTLID-BEGIN)
 363 ; immediate
 364
 365 ;; repeats while the condition is false
 366 : UNTIL
 367   compiler:?comp
 368   ['] 0branch
 369   compiler:(end-begin)
 370 ; immediate
 371
 372 ;; repeats while the condition is true
 373 : NOT-UNTIL
 374   compiler:?comp
 375   ['] tbranch
 376   compiler:(end-begin)
 377 ; immediate
 378
 379 ;; repeats while the number if positive
 380 : -UNTIL
 381   compiler:?comp
 382   ['] +0branch
 383   compiler:(end-begin)
 384 ; immediate
 385
 386 ;; repeats while the number if negative
 387 : +UNTIL
 388   compiler:?comp
 389   ['] -0branch
 390   compiler:(end-begin)
 391 ; immediate
 392
 393 : AGAIN
 394   compiler:?comp
 395   ['] branch
 396   compiler:(end-begin)
 397 ; immediate
 398
 399 alias AGAIN REPEAT
 400
 401 : WHILE
 402   ['] 0branch
 403   compiler:(comp-while)
 404 ; immediate
 405
 406 : NOT-WHILE
 407   ['] tbranch
 408   compiler:(comp-while)
 409 ; immediate
 410
 411 : -WHILE
 412   ['] +0branch
 413   compiler:(comp-while)
 414 ; immediate
 415
 416 : +WHILE
 417   ['] -0branch
 418   compiler:(comp-while)
 419 ; immediate
 420
 421
 422 : CONTINUE
 423   1 compiler:(break/continue)
 424 ; immediate
 425
 426 : BREAK
 427   0 compiler:(break/continue)
 428 ; immediate
 429
 430 ;; this has to be here
 431 alias BREAK LEAVE
 432
 433
 434 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 435 ;; data stack:
 436 ;;   0 (CTLID-CASE)
 437 ;;     addr (CTLID-OF) -- when in "OF"
 438 ;;     addr (CTLID-ENDOF) -- when "ENDOF" compiled
 439 ;;     0 (CTLID-OTHERWISE) -- when "OTHERWISE" compiled
 440 ;; note that "(CTLID-ENDOF)"s will be accumulated, and resolved in "ENDCASE"
 441 ;;
 442
 443 : CASE
 444   compiler:?comp
 445   0 compiler:(CTLID-CASE)  ;; with dummy argument
 446 ; immediate
 447
 448 : OF  ['] forth:(of=) compiler:(x-of) ; immediate
 449 : NOT-OF  ['] forth:(of<>) compiler:(x-of) ; immediate
 450 : <OF  ['] forth:(of<) compiler:(x-of) ; immediate
 451 : <=OF  ['] forth:(of<=) compiler:(x-of) ; immediate
 452 : >OF  ['] forth:(of>) compiler:(x-of) ; immediate
 453 : >=OF  ['] forth:(of>=) compiler:(x-of) ; immediate
 454 : U<OF  ['] forth:(of-U<) compiler:(x-of) ; immediate
 455 : U<=OF  ['] forth:(of-U<=) compiler:(x-of) ; immediate
 456 : U>OF  ['] forth:(of-U>) compiler:(x-of) ; immediate
 457 : U>=OF  ['] forth:(of-U>=) compiler:(x-of) ; immediate
 458 : &OF  ['] forth:(of-and) compiler:(x-of) ; immediate
 459 : AND-OF  ['] forth:(of-and) compiler:(x-of) ; immediate
 460 : ~AND-OF  ['] forth:(of-~and) compiler:(x-of) ; immediate
 461 : WITHIN-OF  ['] forth:(of-within) compiler:(x-of) ; immediate
 462 : BOUNDS-OF  ['] forth:(of-bounds) compiler:(x-of) ; immediate
 463
 464 : ENDOF
 465   compiler:?comp compiler:(CTLID-OF) compiler:?pairs
 466   compile branch
 467   compiler:(mark-j>)
 468   swap compiler:(resolve-j>)
 469   compiler:(CTLID-ENDOF)
 470 ; immediate
 471
 472 : OTHERWISE
 473   compiler:(CTLID-CASE) compiler:(CTLID-ENDOF) compiler:?pairs-any-keepid
 474   0 compiler:(CTLID-OTHERWISE)
 475 ; immediate
 476
 477 : ENDCASE
 478   compiler:?comp
 479   compiler:(end-case)
 480 ; immediate
 481
 482
 483 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 484 : DO
 485   compiler:?comp
 486   compile (do)
 487   compiler:(<j-mark)
 488   compiler:(CTLID-DO)
 489 ; immediate
 490
 491 : LOOP
 492   compiler:?comp
 493   ['] (loop) compiler:(end-loop)
 494 ; immediate
 495
 496 : +LOOP
 497   compiler:?comp
 498   ['] (+loop) compiler:(end-loop)
 499 ; immediate
 500
 501 : ?DO
 502   compiler:?comp
 503   compile ?do-branch
 504   compiler:(mark-j>)
 505   compiler:(CTLID-?DO)
 506   [compile] do
 507 ; immediate
 508
 509
 510 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 511 ;; "FOR" is for loops with "step by 1", from 0
 512 : FOR
 513   compiler:?comp
 514   compile (for)
 515   compiler:(mark-j>)
 516   compiler:(CTLID-?DO)
 517   compiler:(<j-mark)
 518   compiler:(CTLID-DO)
 519 ; immediate
 520
 521 : ENDFOR
 522   [compile] loop
 523 ; immediate