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