scheme.4th

   1 vocabulary scheme
   2 scheme definitions
   3
   4 include term-colours.4th
   5 include defer-is.4th
   6
   7 0 constant number-type
   8 1 constant boolean-type
   9 2 constant character-type
  10 3 constant nil-type
  11 4 constant pair-type
  12 5 constant symbol-type
  13 : istype? ( obj -- obj b )
  14     over = ;
  15
  16 100 constant N
  17 create car-cells N allot
  18 create car-type-cells N allot
  19 create cdr-cells N allot
  20 create cdr-type-cells N allot
  21
  22 variable nextfree
  23 0 nextfree !
  24
  25 : cons ( car-obj cdr-obj -- pair-obj )
  26     cdr-type-cells nextfree @ + !
  27     cdr-cells nextfree @ + !
  28     car-type-cells nextfree @ + !
  29     car-cells nextfree @ + !
  30
  31     nextfree @ pair-type
  32
  33     1 nextfree +!
  34 ;
  35
  36 : car ( pair-obj -- car-obj )
  37     drop
  38     dup car-cells + @ swap
  39     car-type-cells + @
  40 ;
  41
  42 : cdr ( pair-obj -- car-obj )
  43     drop
  44     dup cdr-cells + @ swap
  45     cdr-type-cells + @
  46 ;
  47
  48
  49 \ ---- Read ----
  50
  51 variable parse-idx
  52 variable stored-parse-idx
  53 create parse-str 161 allot
  54 variable parse-str-span
  55
  56 create parse-idx-stack 10 allot
  57 variable parse-idx-sp
  58 parse-idx-stack parse-idx-sp !
  59
  60 : push-parse-idx
  61     parse-idx @ parse-idx-sp @ !
  62     1 parse-idx-sp +!
  63 ;
  64
  65 : pop-parse-idx
  66     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
  67
  68     1 parse-idx-sp -!
  69
  70     parse-idx-sp @ @ parse-idx ! ;
  71
  72
  73 : append-newline
  74     '\n' parse-str parse-str-span @ + !
  75     1 parse-str-span +! ;
  76
  77 : empty-parse-str
  78     0 parse-str-span !
  79     0 parse-idx ! ;
  80
  81 : getline
  82     parse-str 160 expect cr
  83     span @ parse-str-span !
  84     append-newline
  85     0 parse-idx ! ;
  86
  87 : inc-parse-idx
  88     1 parse-idx +! ;
  89
  90 : dec-parse-idx
  91     1 parse-idx -! ;
  92
  93 : charavailable? ( -- bool )
  94     parse-str-span @ parse-idx @ > ;
  95
  96 : nextchar ( -- char )
  97     charavailable? false = if getline then
  98     parse-str parse-idx @ + @ ;
  99
 100 : whitespace? ( -- bool )
 101     nextchar BL =
 102     nextchar '\n' = or ;
 103
 104 : eof? ( -- bool )
 105     nextchar 4 = ;
 106
 107 : delim? ( -- bool )
 108     whitespace?
 109     nextchar [char] ( = or
 110     nextchar [char] ) = or
 111 ;
 112
 113 : eatspaces
 114     begin
 115         whitespace?
 116     while
 117         inc-parse-idx
 118     repeat
 119 ;
 120
 121 : digit? ( -- bool )
 122     nextchar [char] 0 >=
 123     nextchar [char] 9 <=
 124     and ;
 125
 126 : minus? ( -- bool )
 127     nextchar [char] - = ;
 128
 129 : number? ( -- bool )
 130     digit? minus? or false = if
 131         false
 132         exit
 133     then
 134
 135     push-parse-idx
 136     inc-parse-idx
 137
 138     begin digit? while
 139         inc-parse-idx
 140     repeat
 141
 142     delim? if
 143         pop-parse-idx
 144         true
 145     else
 146         pop-parse-idx
 147         false
 148     then
 149 ;
 150
 151 : boolean? ( -- bool )
 152     nextchar [char] # <> if false exit then
 153
 154     push-parse-idx
 155     inc-parse-idx
 156
 157     nextchar [char] t <>
 158     nextchar [char] f <>
 159     and if pop-parse-idx false exit then
 160
 161     inc-parse-idx
 162     delim? if
 163         pop-parse-idx
 164         true
 165     else
 166         pop-parse-idx
 167         false
 168     then
 169 ;
 170
 171 : str-equiv? ( str -- bool )
 172
 173     push-parse-idx
 174
 175     true -rot
 176
 177     swap dup rot + swap
 178
 179     do
 180         i @ nextchar <> if
 181             drop false
 182             leave
 183         then
 184
 185         inc-parse-idx
 186     loop
 187
 188     delim? false = if drop false then
 189
 190     pop-parse-idx
 191 ;
 192
 193 : character? ( -- bool )
 194     nextchar [char] # <> if false exit then
 195
 196     push-parse-idx
 197     inc-parse-idx
 198
 199     nextchar [char] \ <> if pop-parse-idx false exit then
 200
 201     inc-parse-idx
 202
 203     S" newline" str-equiv? if pop-parse-idx true exit then
 204     S" space" str-equiv? if pop-parse-idx true exit then
 205     S" tab" str-equiv? if pop-parse-idx true exit then
 206
 207     charavailable? false = if pop-parse-idx false exit then
 208
 209     pop-parse-idx true
 210 ;
 211
 212 : pair? ( -- bool )
 213     nextchar [char] ( = ;
 214
 215
 216 : readnum ( -- num-atom )
 217     minus? dup if
 218         inc-parse-idx
 219     then
 220
 221     0
 222
 223     begin digit? while
 224         10 * nextchar [char] 0 - +
 225         inc-parse-idx
 226     repeat
 227
 228     swap if negate then
 229
 230     number-type
 231 ;
 232
 233 : readbool ( -- bool-atom )
 234     inc-parse-idx
 235
 236     nextchar [char] f = if
 237         false
 238     else
 239         true
 240     then
 241
 242     inc-parse-idx
 243
 244     boolean-type
 245 ;
 246
 247 : readchar ( -- char-atom )
 248     inc-parse-idx
 249     inc-parse-idx
 250
 251     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 252     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 253     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 254
 255     nextchar character-type
 256
 257     inc-parse-idx
 258 ;
 259
 260 defer read
 261
 262 : readpair ( -- obj )
 263     eatspaces
 264
 265     \ Empty lists
 266     nextchar [char] ) = if
 267         inc-parse-idx
 268
 269         delim? false = if
 270             bold fg red
 271             ." No delimiter following right paren. Aborting." cr
 272             reset-term abort
 273         then
 274
 275         dec-parse-idx
 276
 277         0 nil-type exit
 278     then
 279
 280     \ Read first pair element
 281     read
 282
 283     \ Pairs
 284     eatspaces
 285     nextchar [char] . = if
 286         inc-parse-idx
 287
 288         delim? false = if
 289             bold fg red
 290             ." No delimiter following '.'. Aborting." cr
 291             reset-term abort
 292         then
 293
 294         eatspaces read
 295     else
 296         recurse
 297     then
 298
 299     eatspaces
 300
 301     cons
 302 ;
 303
 304 \ Parse a scheme expression
 305 :noname ( -- obj )
 306
 307     eatspaces
 308
 309     number? if
 310         readnum
 311         exit
 312     then
 313
 314     boolean? if
 315         readbool
 316         exit
 317     then
 318
 319     character? if
 320         readchar
 321         exit
 322     then
 323
 324     pair? if
 325         inc-parse-idx
 326
 327         eatspaces
 328
 329         readpair
 330
 331         eatspaces
 332
 333         nextchar [char] ) <> if
 334             bold red ." Missing closing paren." reset-term cr
 335             abort
 336         then
 337
 338         inc-parse-idx
 339
 340         exit
 341     then
 342
 343     eof? if
 344         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 345         quit
 346     then
 347
 348     bold fg red ." Error parsing string starting at character '"
 349     nextchar emit
 350     ." '. Aborting." reset-term cr
 351     abort
 352
 353 ; is read
 354
 355 \ ---- Eval ----
 356
 357 : self-evaluating? ( obj -- obj bool )
 358     number-type istype? if true exit then
 359     boolean-type istype? if true exit then
 360     character-type istype? if true exit then
 361     nil-type istype? if true exit then
 362     false ;
 363
 364 : eval
 365     \ self-evaluating? if
 366     \     exit
 367     \ then
 368     exit
 369
 370     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 371     abort
 372 ;
 373
 374 \ ---- Print ----
 375
 376 : printnum ( numobj -- ) drop 0 .R ;
 377
 378 : printbool ( numobj -- )
 379     drop if
 380         ." #t"
 381     else
 382         ." #f"
 383     then
 384 ;
 385
 386 : printchar ( charobj -- )
 387     drop
 388     case
 389         9 of ." #\tab" endof
 390         bl of ." #\space" endof
 391         '\n' of ." #\newline" endof
 392
 393         dup ." #\" emit
 394     endcase
 395 ;
 396
 397 : printnil ( nilobj -- )
 398     2drop ." ()" ;
 399
 400 defer print
 401 : printpair ( pairobj -- )
 402     2dup
 403     car print
 404     cdr
 405     nil-type istype? if 2drop exit then
 406     pair-type istype? if space recurse exit then
 407     ."  . " print
 408 ;
 409
 410 :noname ( obj -- )
 411     number-type istype? if printnum exit then
 412     boolean-type istype? if printbool exit then
 413     character-type istype? if printchar exit then
 414     nil-type istype? if printnil exit then
 415     pair-type istype? if ." (" printpair ." )" exit then
 416
 417     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
 418     abort
 419 ; is print
 420
 421 \ ---- REPL ----
 422
 423 : repl
 424     cr ." Welcome to scheme.forth.jl!" cr
 425        ." Use Ctrl-D to exit." cr
 426
 427     empty-parse-str
 428
 429     begin
 430         cr bold fg green ." > " reset-term
 431         read
 432         eval
 433         fg cyan ." ; " print reset-term
 434     again
 435 ;
 436
 437 forth definitions