level0/syssrc/compiler-if-begin-do.f

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