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