urflibs/init/bootstrap/90-cond-comp.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 ;; $DEFINE defname
  10 : $DEFINE
  11   PARSE-NAME DUP " define name expected" ?NOT-ERROR
  12   PARSE-SKIP-LINE-COMMENTS
  13   TIB-PEEKCH " $DEFINE doesn't accept extra args yet" ?ERROR
  14   ($DEFINE)
  15 ;
  16
  17 ;; $UNDEF defname
  18 : $UNDEF
  19   PARSE-NAME DUP " define name expected" ?NOT-ERROR
  20   PARSE-SKIP-LINE-COMMENTS
  21   TIB-PEEKCH " $DEFINE doesn't accept extra args yet" ?ERROR
  22   ($UNDEF)
  23 ;
  24
  25
  26 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;; simple expression evaluator
  28 ;;
  29
  30 VOCABULARY ($CC-EVAL)
  31 ALSO ($CC-EVAL) DEFINITIONS
  32
  33 0 VALUE CURR-WORD-ADDR
  34 0 VALUE CURR-WORD-LEN
  35 0 VALUE $IF-COUNT
  36 0 VALUE ALLOW-CONTINUATIONS
  37
  38 0 VALUE ($CC-TRACE)
  39
  40 DEFER $SKIP-CONDS
  41 DEFER $CC-EXPR  ( doeval? -- value )
  42
  43
  44 : CURR-WORD  ( -- addr count )  CURR-WORD-ADDR CURR-WORD-LEN ;
  45
  46 : ONE-CHAR-WORD  ( -- )
  47   (TIB-IN) TO CURR-WORD-ADDR  1 TO CURR-WORD-LEN  TIB-SKIPCH
  48 ;
  49
  50 ;; one or two same chars
  51 : ONE-TWO-CHAR-WORD  ( -- )
  52   (TIB-IN) TO CURR-WORD-ADDR
  53   TIB-GETCH TIB-PEEKCH = IF TIB-SKIPCH 2 TO CURR-WORD-LEN
  54   ELSE 1 TO CURR-WORD-LEN
  55   ENDIF
  56 ;
  57
  58 : IS-SPECIAL-CHAR  ( ch -- bool )
  59   CASE
  60     [CHAR] ! OF TRUE ENDOF
  61     [CHAR] ( OF TRUE ENDOF
  62     [CHAR] \ OF TRUE ENDOF
  63     [CHAR] ) OF TRUE ENDOF
  64     [CHAR] ~ OF TRUE ENDOF
  65     [CHAR] & OF TRUE ENDOF
  66     [CHAR] | OF TRUE ENDOF
  67     [CHAR] ; OF TRUE ENDOF
  68     OTHERWISE DROP FALSE
  69   ENDCASE
  70 ;
  71
  72 : CC-PARSE-SPECIAL  ( -- )
  73   TIB-PEEKCH DUP [CHAR] & = SWAP [CHAR] | = OR
  74   IF ONE-TWO-CHAR-WORD ELSE ONE-CHAR-WORD ENDIF
  75 ;
  76
  77 : CC-PARSE-ID  ( -- )
  78   (TIB-IN) TO CURR-WORD-ADDR
  79   BEGIN
  80     TIB-PEEKCH DUP BL > SWAP IS-SPECIAL-CHAR NOT AND
  81   WHILE
  82     TIB-SKIPCH
  83   REPEAT
  84   (TIB-IN) CURR-WORD-ADDR - TO CURR-WORD-LEN
  85 ;
  86
  87 : NEXT-WORD  ( -- )
  88   BEGIN
  89     TIB-PEEKCH CASE
  90       0 OF (TIB-IN) TO CURR-WORD-ADDR  0 TO CURR-WORD-LEN  TRUE ENDOF
  91       [CHAR] ; OF ONE-CHAR-WORD PARSE-SKIP-LINE  0 TO CURR-WORD-LEN  TRUE ENDOF
  92       [CHAR] \ OF  ;; possible continuation
  93           ALLOW-CONTINUATIONS IF
  94             TIB-SKIPCH PARSE-SKIP-BLANKS
  95             TIB-PEEKCH " invalid continuation" ?ERROR
  96             REFILL-NOCROSS " unexpected end of file" ?NOT-ERROR
  97             FALSE
  98           ELSE ONE-CHAR-WORD TRUE
  99           ENDIF
 100         ENDOF
 101       BL <=OF TIB-SKIPCH FALSE ENDOF
 102       OTHERWISE
 103         IS-SPECIAL-CHAR IF CC-PARSE-SPECIAL ELSE CC-PARSE-ID ENDIF
 104         TRUE
 105     ENDCASE
 106   UNTIL
 107   \ ." |" CURR-WORD XTYPE ." | -- " TIB-PEEKCH XEMIT CR
 108 ;
 109
 110 ;; parse required argument in parens
 111 : NEXT-WORD-ARG  ( -- )
 112   NEXT-WORD CURR-WORD " (" STRING:= " '(' expected" ?NOT-ERROR
 113   PARSE-SKIP-BLANKS
 114   ;; quoted?
 115   TIB-PEEKCH DUP 34 = OVER 96 = OR SWAP 39 = OR IF
 116     TIB-GETCH PARSE " argument expected" ?NOT-ERROR
 117     TO CURR-WORD-LEN TO CURR-WORD-ADDR
 118   ELSE
 119     ;; parse up to blank or ")"
 120     PARSE-SKIP-BLANKS
 121     (TIB-IN) TO CURR-WORD-ADDR  0 TO CURR-WORD-LEN
 122     BEGIN
 123       TIB-PEEKCH DUP BL <= SWAP 41 = OR
 124     NOT-WHILE
 125       TIB-SKIPCH
 126       CURR-WORD-LEN 1+ TO CURR-WORD-LEN
 127     REPEAT
 128   ENDIF
 129   \ ." |" CURR-WORD XTYPE ." | -- " TIB-PEEKCH XEMIT CR
 130   CURR-WORD-LEN 1 = CURR-WORD-ADDR C@ IS-SPECIAL-CHAR AND " identifier required" ?ERROR
 131   CURR-WORD  ;; save address
 132   ;; check final ")"
 133   NEXT-WORD CURR-WORD " )" STRING:= " ')' expected" ?NOT-ERROR
 134   ;; restore word
 135   TO CURR-WORD-LEN TO CURR-WORD-ADDR
 136   \ ." ||" CURR-WORD XTYPE ." | -- " TIB-PEEKCH XEMIT CR
 137 ;
 138
 139
 140 VOCABULARY ($CC-EVAL-TERMS)
 141 ALSO ($CC-EVAL-TERMS) DEFINITIONS
 142
 143 : DEFINED    ( -- val )
 144   NEXT-WORD-ARG CURR-WORD FORTH:($DEFINED?)
 145   ?DUP IFNOT  ;; try without a leading dollar
 146     CURR-WORD-LEN 2 >  CURR-WORD-ADDR C@ [CHAR] $ =  AND IF
 147       CURR-WORD-ADDR 1+ CURR-WORD-LEN 1- FORTH:($DEFINED?)
 148     ELSE FALSE
 149     ENDIF
 150   ENDIF
 151 ;
 152 : UNDEFINED  ( -- val )  DEFINED NOT ;
 153 : HAS-WORD   ( -- val )  NEXT-WORD-ARG CURR-WORD FIND-WORD IF DROP TRUE ELSE FALSE ENDIF ;
 154 : NO-WORD    ( -- val )  HAS-WORD NOT ;
 155 ALIAS UNDEFINED NOT-DEFINED
 156
 157 PREVIOUS DEFINITIONS
 158
 159
 160 : $CC-TERM  ( -- value )
 161   \ ." $TERM: " CURR-WORD XTYPE CR
 162   CURR-WORD VOCID: ($CC-EVAL-TERMS) FIND-WORD-IN-VOC  ( cfa TRUE / FALSE )
 163   IF EXECUTE
 164   \ ." $TERM:   RES: " DUP . CR
 165   ELSE
 166     ;; special syntax: $DEFVARNAME
 167     CURR-WORD-LEN 2 > CURR-WORD-ADDR C@ 36 = AND IF
 168       CURR-WORD-ADDR 1+ CURR-WORD-LEN 1- FORTH:($DEFINED?)
 169     ELSE
 170       CURR-WORD TRUE BASE @ FORTH:(BASED-NUMBER)  ( num TRUE / FALSE )
 171       IFNOT ENDCR SPACE CURR-WORD XTYPE ." ? -- wut?!\n" " unknown term" ERROR ENDIF
 172     ENDIF
 173   ENDIF
 174   NEXT-WORD
 175 ;
 176
 177 : $CC-UNARY  ( -- value )
 178   CURR-WORD " (" STRING:= IF
 179     NEXT-WORD $CC-EXPR
 180     CURR-WORD " )" STRING:= " unbalanced parens" ?NOT-ERROR
 181     NEXT-WORD
 182   ELSE
 183     CURR-WORD " NOT" STRING:=CI
 184     CURR-WORD " !" STRING:= OR
 185     CURR-WORD " ~" STRING:= OR
 186     IF NEXT-WORD RECURSE NOT
 187     ELSE $CC-TERM
 188     ENDIF
 189   ENDIF
 190 ;
 191
 192 : $IS-LOGAND  ( -- bool )
 193   CURR-WORD " AND" STRING:=CI
 194   CURR-WORD " &&" STRING:= OR
 195   CURR-WORD " &" STRING:= OR
 196 ;
 197
 198 : $IS-LOGOR  ( -- bool )
 199   CURR-WORD " OR" STRING:=CI
 200   CURR-WORD " ||" STRING:= OR
 201   CURR-WORD " |" STRING:= OR
 202 ;
 203
 204 : ($CC-LOG-CREATE)  ( cfacheck cfalogop cfanext -- value )
 205   CREATE
 206   ;; PFA: cfanext cfacheck cfaop
 207   -FIND-REQUIRED ,  ;; cfanext
 208   -FIND-REQUIRED ,  ;; cfacheck
 209   -FIND-REQUIRED ,  ;; cfaop
 210  DOES>  ( pfa -- value )
 211   DUP >R @ EXECUTE
 212   BEGIN
 213     R@ CELL+ @ EXECUTE
 214   WHILE
 215     NEXT-WORD R@ @ EXECUTE
 216     R@ 2 +CELLS @ EXECUTE
 217   REPEAT
 218   RDROP
 219 ;
 220
 221 ($CC-LOG-CREATE) $CC-AND  $CC-UNARY $IS-LOGAND LOGAND
 222 ($CC-LOG-CREATE) $CC-OR   $CC-AND   $IS-LOGOR  LOGOR
 223
 224 : ($CC-EXPR)  ( -- )
 225   ALLOW-CONTINUATIONS >R
 226   1 TO ALLOW-CONTINUATIONS $CC-OR
 227   R> TO ALLOW-CONTINUATIONS
 228 ;
 229
 230 ' ($CC-EXPR) TO $CC-EXPR
 231
 232
 233 : ENSURE-EOL
 234   PARSE-SKIP-BLANKS
 235   TIB-PEEKCH ?DUP IF
 236     [CHAR] ; <> " invalid expression" ?ERROR
 237     PARSE-SKIP-LINE
 238   ENDIF
 239 ;
 240
 241 : $PROCESS-COND
 242   NEXT-WORD $CC-EXPR ENSURE-EOL
 243   IF $IF-COUNT 1+ TO $IF-COUNT
 244   ELSE TRUE $SKIP-CONDS
 245   ENDIF
 246 ;
 247
 248 \ 0 VALUE ($SKIP-FROM-LINE)
 249
 250 : ($SKIP-CONDS)  ( toelse -- )
 251   (*
 252     ." SKIP: LINE=" 0 (INCLUDE-FILE-LINE) .
 253     ." FILE: " 0 (INCLUDE-FILE-NAME) XTYPE CR
 254   *)
 255   0 >R  ( toelse | level )
 256   BEGIN
 257     REFILL-NOCROSS " unexpected end of file" ?NOT-ERROR
 258     NEXT-WORD
 259     FALSE  ( toelse done? | level )
 260     CURR-WORD " $IF" STRING:=CI IF DROP R> 1+ >R FALSE ENDIF
 261     CURR-WORD " $ENDIF" STRING:=CI IF DROP
 262       ;; in nested ifs, look only for $ENDIF
 263       R@ IF R> 1- >R FALSE
 264       ELSE
 265         ;; it doesn't matter which part we're skipping, it ends here anyway
 266         TRUE
 267       ENDIF
 268     ENDIF
 269     CURR-WORD " $ELSE" STRING:=CI IF DROP
 270       ;; if we're skipping "true" part, go on
 271       DUP IF
 272         $IF-COUNT 1+ TO $IF-COUNT
 273         R@ 0=  \ FALSE
 274       ELSE
 275         ;; we're skipping "false" part, there should be no else
 276         " unexpected $ELSE" ERROR
 277       ENDIF
 278     ENDIF
 279     ;; only for level 0
 280     R@ IFNOT
 281       CURR-WORD " $ELIF" STRING:=CI IF DROP
 282         ;; if we're skipping "true" part, go on
 283         DUP IF
 284           ;; process the conditional
 285           $CC-EXPR ENSURE-EOL
 286           ;; either resume normal execution, or keep searching for $ELSE
 287           IF
 288             $IF-COUNT 1+ TO $IF-COUNT TRUE
 289           ELSE FALSE
 290           ENDIF
 291         ELSE
 292           ;; we're skipping "false" part, there should be no else
 293           " unexpected $ELIF" ERROR
 294         ENDIF
 295       ENDIF
 296     ENDIF
 297   UNTIL
 298   DROP  ;; drop `toelse`
 299   R> 0<> " oops?" ?ERROR
 300   \ REFILL " unexpected end of file" ?NOT-ERROR
 301   PARSE-SKIP-LINE
 302 ;
 303
 304 ' ($SKIP-CONDS) TO $SKIP-CONDS
 305
 306 PREVIOUS DEFINITIONS
 307
 308
 309 : $IF
 310   ($CC-EVAL):$PROCESS-COND
 311 ; IMMEDIATE
 312
 313 : $ELSE
 314   ($CC-EVAL):$IF-COUNT " unexpected $ELSE" ?NOT-ERROR
 315   ($CC-EVAL):ENSURE-EOL
 316   FALSE ($CC-EVAL):$SKIP-CONDS
 317 ; IMMEDIATE
 318
 319 : $ELIF
 320   ($CC-EVAL):$IF-COUNT " unexpected $ELIF" ?NOT-ERROR
 321   ($CC-EVAL):$IF-COUNT 1- TO ($CC-EVAL):$IF-COUNT
 322   FALSE ($CC-EVAL):$SKIP-CONDS
 323 ; IMMEDIATE
 324
 325 : $ENDIF
 326   ($CC-EVAL):$IF-COUNT " unexpected $ENDIF" ?NOT-ERROR
 327   ($CC-EVAL):ENSURE-EOL
 328   ($CC-EVAL):$IF-COUNT 1- TO ($CC-EVAL):$IF-COUNT
 329 ; IMMEDIATE
 330
 331
 332 ALSO ($CC-EVAL):($CC-EVAL-TERMS) DEFINITIONS
 333 ALSO ($CC-EVAL)
 334
 335 $IF HAS-WORD(URASM:HAS-LABEL?)
 336 : HAS-LABEL  ( -- val )  NEXT-WORD-ARG CURR-WORD URASM:HAS-LABEL? ;
 337 : NO-LABEL   ( -- val )  HAS-LABEL NOT ;
 338 $ENDIF
 339
 340 $IF HAS-WORD(URASM:PASS@)
 341 : PASS0      ( -- val )  URASM:PASS@ 0= ;
 342 : PASS1      ( -- val )  URASM:PASS@ 0<> ;
 343 ALIAS PASS0 PASS-0
 344 ALIAS PASS1 PASS-1
 345 $ENDIF
 346
 347 PREVIOUS PREVIOUS DEFINITIONS