urflibs/init/bootstrap/30-ifthen.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrForth/C Forth Engine!
   4 ;; Copyright (C) 2023 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;; IF/ELSE/ENDIF
  10 ;;
  11 ALSO COMPILER DEFINITIONS
  12
  13   1 CONSTANT PAIR-BEGIN
  14   2 CONSTANT PAIR-IF
  15   3 CONSTANT PAIR-IFELSE
  16   4 CONSTANT PAIR-DO
  17   5 CONSTANT PAIR-CASE
  18   6 CONSTANT PAIR-OF
  19   7 CONSTANT PAIR-OTHER
  20   8 CONSTANT PAIR-WHILE
  21   9 CONSTANT PAIR-FOR
  22  10 CONSTANT PAIR-QDO
  23 666 CONSTANT PAIR-CBLOCK
  24
  25 0 VARIABLE (CHAIN-BREAK)
  26 0 VARIABLE (CHAIN-CONT)
  27 0 VARIABLE (LOOP-PAIR)
  28
  29
  30 ;; WHILE
  31 ;; ( saved-break saved-cont saved-lastpair begin-id branchcfa -- saved-break saved-cont saved-lastpair begin-id )
  32 ;; all failed whiles will terminate the loop
  33 : (COMPILE-WHILE)
  34   ?COMP SWAP PAIR-BEGIN ?PAIRS
  35   COMPILE, (CHAIN-BREAK) @ (CHAIN-J>) (CHAIN-BREAK) !
  36   PAIR-BEGIN
  37 ;
  38
  39 ;; AGAIN
  40 ;; ( saved-break saved-cont saved-lastpair begin-id branchcfa -- )
  41 ;; ( -- saved-break saved-cont saved-lastpair begin-id )
  42 : (COMPILE-UNTIL)
  43   ?COMP SWAP PAIR-BEGIN ?PAIRS
  44   COMPILE, (CHAIN-CONT) @ (<J-RESOLVE)
  45   (CHAIN-BREAK) @ (RESOLVE-J>)
  46   (LOOP-PAIR) !  (CHAIN-CONT) !  (CHAIN-BREAK) !
  47 ;
  48
  49 : (COUNTED-LOOP?)  ( n -- bool )
  50   DUP PAIR-DO =  OVER PAIR-QDO = OR  SWAP PAIR-FOR = OR
  51 ;
  52
  53
  54 PREVIOUS DEFINITIONS ALSO COMPILER
  55
  56 : (IF-COMMON)  ( branch-cfa -- )
  57   ?COMP COMPILE, (MARK-J>)
  58   PAIR-IF
  59 ;
  60
  61 : IF    ( -- addr id )  ['] FORTH:(0BRANCH) (IF-COMMON) ; IMMEDIATE
  62 : IFNOT ( -- addr id )  ['] FORTH:(TBRANCH) (IF-COMMON) ; IMMEDIATE
  63 : -IF   ( -- addr id )  ['] FORTH:(+0BRANCH) (IF-COMMON) ; IMMEDIATE  -- if negative
  64 : +IF   ( -- addr id )  ['] FORTH:(-0BRANCH) (IF-COMMON) ; IMMEDIATE  -- if positive (but not zero)
  65 : -0IF  ( -- addr id )  ['] FORTH:(+BRANCH) (IF-COMMON) ; IMMEDIATE  -- if negative or 0
  66 : +0IF  ( -- addr id )  ['] FORTH:(-BRANCH) (IF-COMMON) ; IMMEDIATE  -- if positive or 0
  67
  68 ;; ENDIF
  69 : ENDIF
  70   ?COMP PAIR-IF PAIR-IFELSE ?2PAIRS
  71   (RESOLVE-J>)
  72 ; IMMEDIATE
  73
  74 ;; THEN
  75 : THEN
  76   [COMPILE] ENDIF
  77 ; IMMEDIATE
  78
  79 ;; ELSE
  80 : ELSE
  81   ?COMP PAIR-IF ?PAIRS
  82   COMPILE FORTH:(BRANCH) (MARK-J>)
  83   SWAP (RESOLVE-J>)
  84   PAIR-IFELSE
  85 ; IMMEDIATE
  86
  87
  88 ;; BEGIN
  89 ;; ( -- saved-break saved-cont saved-lastpair begin-jmark begin-id )
  90 : BEGIN
  91   ?COMP
  92   (CHAIN-BREAK) @  (CHAIN-CONT) @  (LOOP-PAIR) @
  93   (CHAIN-BREAK) 0!  (<J-MARK) (CHAIN-CONT) !
  94   PAIR-BEGIN DUP (LOOP-PAIR) !
  95 ; IMMEDIATE
  96
  97 ;; WHILE
  98 ;; all failed whiles will terminate the loop
  99 : WHILE      ['] FORTH:(0BRANCH) (COMPILE-WHILE) ; IMMEDIATE
 100 : NOT-WHILE  ['] FORTH:(TBRANCH) (COMPILE-WHILE) ; IMMEDIATE
 101 : -WHILE     ['] FORTH:(+0BRANCH) (COMPILE-WHILE) ; IMMEDIATE
 102 : +WHILE     ['] FORTH:(-0BRANCH) (COMPILE-WHILE) ; IMMEDIATE
 103 : -0WHILE    ['] FORTH:(+BRANCH) (COMPILE-WHILE) ; IMMEDIATE
 104 : +0WHILE    ['] FORTH:(-BRANCH) (COMPILE-WHILE) ; IMMEDIATE
 105
 106 ;; AGAIN
 107 : AGAIN  ['] FORTH:(BRANCH) (COMPILE-UNTIL) ; IMMEDIATE
 108 : REPEAT  [COMPILE] AGAIN ;  IMMEDIATE
 109
 110 : UNTIL      ['] FORTH:(0BRANCH) (COMPILE-UNTIL) ; IMMEDIATE
 111 : NOT-UNTIL  ['] FORTH:(TBRANCH) (COMPILE-UNTIL) ; IMMEDIATE
 112 : -UNTIL     ['] FORTH:(+0BRANCH) (COMPILE-UNTIL) ; IMMEDIATE
 113 : +UNTIL     ['] FORTH:(-0BRANCH) (COMPILE-UNTIL) ; IMMEDIATE
 114 : -0UNTIL    ['] FORTH:(+BRANCH) (COMPILE-UNTIL) ; IMMEDIATE
 115 : +0UNTIL    ['] FORTH:(-BRANCH) (COMPILE-UNTIL) ; IMMEDIATE
 116
 117
 118 ;; (DO)
 119 : (DO)  ( limit start -- | limit counter )
 120   ;; index = 0x8000_0000 - to + from
 121   ;; limit = 0x8000_0000 - to
 122   R> NROT   ( ret to from )
 123   0x8000_0000 ROT -   ( ret from 0x8000_0000-to )
 124   DUP >R + >R >R
 125 ; (HIDDEN)
 126
 127 ;; (?DO)
 128 : (?DO)  ( limit start -- | limit counter )
 129   2DUP <> IF  ;; do it
 130     ;; index = 0x8000_0000 - to + from
 131     ;; limit = 0x8000_0000 - to
 132     R> NROT   ( ret to from )
 133     0x8000_0000 ROT -   ( ret from 0x8000_0000-to )
 134     DUP >R + >R
 135     4+  ( skip branch address )
 136   ELSE  ;; skip it
 137     2DROP R> @
 138   ENDIF
 139   >R
 140 ; (HIDDEN)  COMPILER:(WARG-BRANCH) COMPILER:SET-WARG
 141
 142 ;; exit when counter crosses a limit
 143 : (+LOOP)  ( add -- | limit index )
 144   R> SWAP
 145   R@ +  ( ret add+index )
 146   R@ OVER XOR 0< IF  ( ret add+index )
 147     ;; break
 148     DROP RDROP RDROP 4+
 149   ELSE  ( ret add+index )
 150     ;; continue
 151     RDROP >R @
 152   ENDIF
 153   >R
 154 ; (HIDDEN)  COMPILER:(WARG-BRANCH) COMPILER:SET-WARG
 155 \ DEBUG:DECOMPILE FORTH:(+LOOP)
 156
 157 : (I)  ( | limit index -- real-index | limit index )
 158   1 RPICK 2 RPICK -
 159 ;
 160
 161 : (J)  ( | limit0 index0 limit1 index1 -- real-index0 | limit0 index0 limit1 index1 )
 162   3 RPICK 4 RPICK -
 163 ;
 164
 165 : (UNLOOP)
 166   R> RDROP RDROP >R
 167 ;
 168
 169 : DO
 170   ?COMP
 171   COMPILE FORTH:(DO)
 172   (CHAIN-BREAK) @  (CHAIN-CONT) @  (LOOP-PAIR) @
 173   (CHAIN-BREAK) 0!  (<J-MARK) (CHAIN-CONT) !
 174   PAIR-DO DUP (LOOP-PAIR) !
 175 ; IMMEDIATE
 176
 177 : ?DO
 178   ?COMP
 179   COMPILE FORTH:(?DO)
 180   (CHAIN-BREAK) @  (CHAIN-CONT) @  (LOOP-PAIR) @
 181   (MARK-J>) (CHAIN-BREAK) !  (<J-MARK) (CHAIN-CONT) !
 182   PAIR-QDO DUP (LOOP-PAIR) !
 183 ; IMMEDIATE
 184
 185 : (LOOP-FINISH)  ( loop-id -- )
 186   DROP COMPILE FORTH:(+LOOP)
 187   (CHAIN-CONT) @ (<J-RESOLVE)
 188   (CHAIN-BREAK) @ (RESOLVE-J>)
 189   (LOOP-PAIR) !  (CHAIN-CONT) !  (CHAIN-BREAK) !
 190 ; (HIDDEN)
 191
 192 : LOOP
 193   ?COMP DUP PAIR-DO PAIR-QDO ?2PAIRS
 194   1 LITERAL FORTH:(LOOP-FINISH)
 195 ; IMMEDIATE
 196
 197 : +LOOP
 198   ?COMP DUP PAIR-DO PAIR-QDO ?2PAIRS
 199   FORTH:(LOOP-FINISH)
 200 ; IMMEDIATE
 201
 202 : I
 203   ?COMP (LOOP-PAIR) @ (COUNTED-LOOP?) " 'I' out of a loop" ?NOT-ERROR
 204   COMPILE (I)
 205 ; IMMEDIATE
 206
 207 : J
 208   ?COMP (LOOP-PAIR) @ (COUNTED-LOOP?) " 'J' out of a loop" ?NOT-ERROR
 209   COMPILE (J)
 210 ; IMMEDIATE
 211
 212
 213 ;; FOR
 214 : (FOR)  ( limit -- | limit counter )
 215   DUP 0> IF  ;; do it
 216     ;; index = 0x8000_0000 - to + from
 217     ;; limit = 0x8000_0000 - to
 218     0 R> NROT   ( ret to from )
 219     0x8000_0000 ROT -   ( ret from 0x8000_0000-to )
 220     DUP >R + >R
 221     4+  ( skip branch address )
 222   ELSE  ;; skip it
 223     DROP R> @
 224   ENDIF
 225   >R
 226 ; (HIDDEN)  COMPILER:(WARG-BRANCH) COMPILER:SET-WARG
 227
 228 : (ENDFOR)  ( -- | limit counter )
 229   R>
 230   R@ 1+  ( ret add+index )
 231   R@ OVER XOR 0< IF  ( ret add+index )
 232     ;; break
 233     DROP RDROP RDROP 4+
 234   ELSE  ( ret add+index )
 235     ;; continue
 236     RDROP >R @
 237   ENDIF
 238   >R
 239 ; (HIDDEN)  COMPILER:(WARG-BRANCH) COMPILER:SET-WARG
 240
 241 : FOR
 242   ?COMP
 243   COMPILE FORTH:(FOR)
 244   (CHAIN-BREAK) @  (CHAIN-CONT) @  (LOOP-PAIR) @
 245   (MARK-J>) (CHAIN-BREAK) !   (CHAIN-CONT) 0!
 246   (<J-MARK) PAIR-FOR DUP (LOOP-PAIR) !
 247 ; IMMEDIATE
 248
 249 : ENDFOR
 250   ?COMP PAIR-FOR ?PAIRS
 251   ;; continue points here
 252   (CHAIN-CONT) @ (RESOLVE-J>)
 253   COMPILE (ENDFOR) (<J-RESOLVE)
 254   ;; break points here
 255   (CHAIN-BREAK) @ (RESOLVE-J>)
 256   (LOOP-PAIR) !  (CHAIN-CONT) !  (CHAIN-BREAK) !
 257 ; IMMEDIATE
 258
 259
 260 ;; CASE
 261 : CASE
 262   ?COMP 0 PAIR-CASE
 263 ; IMMEDIATE
 264
 265 : ENDCASE
 266   ?COMP
 267   DUP PAIR-OTHER = IF
 268     DROP  ;; pair-id
 269   ELSE PAIR-CASE ?PAIRS
 270     COMPILE DROP
 271   ENDIF
 272   ;; jump out of the cases
 273   COMPILER:(RESOLVE-J>)
 274 ; IMMEDIATE
 275
 276 DEFINITIONS
 277
 278 : (COMPILE-OF)  ( cmpcfa -- )
 279   ?COMP SWAP PAIR-CASE ?PAIRS
 280   COMPILE, COMPILE FORTH:(0BRANCH) COMPILER:(MARK-J>)
 281   COMPILE DROP
 282   PAIR-OF
 283 ; (HIDDEN)
 284
 285 : (OF=)  OVER = ; (HIDDEN)
 286 : (OF<>)  OVER <> ; (HIDDEN)
 287 : (OF<)  OVER SWAP < ; (HIDDEN)
 288 : (OF<=)  OVER SWAP <= ; (HIDDEN)
 289 : (OF>)  OVER SWAP > ; (HIDDEN)
 290 : (OF>=)  OVER SWAP >= ; (HIDDEN)
 291 : (OF-U<)  OVER SWAP < ; (HIDDEN)
 292 : (OF-U<=)  OVER SWAP <= ; (HIDDEN)
 293 : (OF-U>)  OVER SWAP > ; (HIDDEN)
 294 : (OF-U>=)  OVER SWAP >= ; (HIDDEN)
 295 : (OF-AND)  OVER AND ; (HIDDEN)
 296 : (OF-~AND)  OVER SWAP BITNOT AND ; (HIDDEN)
 297 : (OF-WITHIN)  >R >R DUP R> R> WITHIN ; (HIDDEN)
 298 : (OF-UWITHIN)  >R >R DUP R> R> UWITHIN ; (HIDDEN)
 299 : (OF-BOUNDS)  >R >R DUP R> R> BOUNDS? ; (HIDDEN)
 300
 301 PREVIOUS DEFINITIONS ALSO COMPILER
 302
 303 : OF         ['] COMPILER:(OF=) COMPILER:(COMPILE-OF) ; IMMEDIATE
 304 : NOT-OF     ['] COMPILER:(OF<>) COMPILER:(COMPILE-OF) ; IMMEDIATE
 305 : <OF        ['] COMPILER:(OF<) COMPILER:(COMPILE-OF) ; IMMEDIATE
 306 : <=OF       ['] COMPILER:(OF<=) COMPILER:(COMPILE-OF) ; IMMEDIATE
 307 : >OF        ['] COMPILER:(OF>) COMPILER:(COMPILE-OF) ; IMMEDIATE
 308 : >=OF       ['] COMPILER:(OF>=) COMPILER:(COMPILE-OF) ; IMMEDIATE
 309 : U<OF       ['] COMPILER:(OF-U<) COMPILER:(COMPILE-OF) ; IMMEDIATE
 310 : U<=OF      ['] COMPILER:(OF-U<=) COMPILER:(COMPILE-OF) ; IMMEDIATE
 311 : U>OF       ['] COMPILER:(OF-U>) COMPILER:(COMPILE-OF) ; IMMEDIATE
 312 : U>=OF      ['] COMPILER:(OF-U>=) COMPILER:(COMPILE-OF) ; IMMEDIATE
 313 : &OF        ['] COMPILER:(OF-AND) COMPILER:(COMPILE-OF) ; IMMEDIATE
 314 : AND-OF     ['] COMPILER:(OF-AND) COMPILER:(COMPILE-OF) ; IMMEDIATE
 315 : ~AND-OF    ['] COMPILER:(OF-~AND) COMPILER:(COMPILE-OF) ; IMMEDIATE
 316 : WITHIN-OF  ['] COMPILER:(OF-WITHIN) COMPILER:(COMPILE-OF) ; IMMEDIATE
 317 : UWITHIN-OF ['] COMPILER:(OF-UWITHIN) COMPILER:(COMPILE-OF) ; IMMEDIATE
 318 : BOUNDS-OF  ['] COMPILER:(OF-BOUNDS) COMPILER:(COMPILE-OF) ; IMMEDIATE
 319
 320 : ENDOF
 321   ?COMP PAIR-OF ?PAIRS
 322   ;; jump out of the case
 323   SWAP COMPILE FORTH:(BRANCH) COMPILER:(CHAIN-J>)
 324   ;; fix previous OF jump
 325   SWAP COMPILER:(RESOLVE-J>)
 326   PAIR-CASE
 327 ; IMMEDIATE
 328
 329 : OTHERWISE
 330   ?COMP PAIR-CASE ?PAIRS
 331   PAIR-OTHER
 332 ; IMMEDIATE
 333
 334
 335 ;; BREAK
 336 : BREAK
 337   ?COMP
 338   (LOOP-PAIR) @ PAIR-BEGIN = IF
 339     COMPILE FORTH:(BRANCH) (CHAIN-BREAK) @ (CHAIN-J>) (CHAIN-BREAK) !
 340   ELSE (LOOP-PAIR) @ (COUNTED-LOOP?) IF
 341     COMPILE FORTH:(UNLOOP)
 342     COMPILE FORTH:(BRANCH) (CHAIN-BREAK) @ (CHAIN-J>) (CHAIN-BREAK) !
 343   ELSE " 'BREAK' out of loop" ERROR
 344   ENDIF ENDIF
 345 ; IMMEDIATE
 346
 347 ;; CONTINUE
 348 : CONTINUE
 349   ?COMP
 350   (LOOP-PAIR) @ PAIR-BEGIN = IF
 351     COMPILE FORTH:(BRANCH) (CHAIN-CONT) @ (<J-RESOLVE)
 352   ELSE (LOOP-PAIR) @ PAIR-FOR = IF
 353     ;; in "FOR", "CONTINUE" is a forward jump to "ENDFOR"
 354     COMPILE FORTH:(BRANCH) (CHAIN-CONT) @ (CHAIN-J>) (CHAIN-CONT) !
 355   ELSE (LOOP-PAIR) @ (COUNTED-LOOP?) " 'CONTINUE' out of loop" ?NOT-ERROR
 356     1 LITERAL COMPILE FORTH:(+LOOP) (CHAIN-CONT) @ (<J-RESOLVE)
 357     COMPILE FORTH:(BRANCH) (CHAIN-BREAK) @ (CHAIN-J>) (CHAIN-BREAK) !
 358   ENDIF ENDIF
 359 ; IMMEDIATE
 360
 361
 362 PREVIOUS