urflibs/init/bootstrap/90-cond-comp.f

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