X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=c4d5d4c768d926644da4c5b760dc416b4e382de6;hb=33a3155409982b2aa10274e05c0f53691038e870;hp=061d36d4deec6047d0e5bbd9a2a13484794c6282;hpb=265928153dc137aef799ad21eaaaaa71103d6c91;p=scheme.forth.jl.git diff --git a/scheme.4th b/scheme.4th index 061d36d..c4d5d4c 100644 --- a/scheme.4th +++ b/scheme.4th @@ -1,43 +1,71 @@ -\ Scheme interpreter - vocabulary scheme scheme definitions include term-colours.4th 0 constant number-type +1 constant boolean-type +2 constant character-type : istype? ( obj -- obj b ) over = ; \ ---- Read ---- variable parse-idx -variable dummy-parse-idx +variable stored-parse-idx +create parse-str 161 allot +variable parse-str-span + +create parse-idx-stack 10 allot +variable parse-idx-sp +parse-idx-stack parse-idx-sp ! + +: push-parse-idx + parse-idx @ parse-idx-sp @ ! + 1 parse-idx-sp +! +; + +: pop-parse-idx + parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow." + + 1 parse-idx-sp -! -: store-parse-idx - parse-idx @ dummy-parse-idx ! ; + parse-idx-sp @ @ parse-idx ! ; + + +: append-newline + '\n' parse-str parse-str-span @ + ! + 1 parse-str-span +! ; + +: empty-parse-str + 0 parse-str-span ! + 0 parse-idx ! ; + +: getline + parse-str 160 expect cr + span @ parse-str-span ! + append-newline + 0 parse-idx ! ; -: restore-parse-idx - dummy-parse-idx @ parse-idx ! ; +: inc-parse-idx + 1 parse-idx +! ; -variable parse-str +: dec-parse-idx + 1 parse-idx -! ; : charavailable? ( -- bool ) - parse-str @ @ parse-idx @ > -; + parse-str-span @ parse-idx @ > ; : nextchar ( -- char ) - charavailable? if - parse-str @ 1+ parse-idx @ + @ - else - 0 - then -; + charavailable? false = if getline then + parse-str parse-idx @ + @ ; : whitespace? ( -- bool ) nextchar BL = - nextchar '\n' = or -; + nextchar '\n' = or ; + +: eof? ( -- bool ) + nextchar 4 = ; : delim? ( -- bool ) whitespace? @@ -49,7 +77,7 @@ variable parse-str begin whitespace? while - 1 parse-idx +! + inc-parse-idx repeat ; @@ -67,32 +95,93 @@ variable parse-str exit then - store-parse-idx - 1 parse-idx +! + push-parse-idx + inc-parse-idx begin digit? while - 1 parse-idx +! + inc-parse-idx repeat - delim? charavailable? false = or if - restore-parse-idx + delim? if + pop-parse-idx true else - restore-parse-idx + pop-parse-idx false then ; +: boolean? ( -- bool ) + nextchar [char] # <> if false exit then + + push-parse-idx + inc-parse-idx + + nextchar [char] t <> + nextchar [char] f <> + and if pop-parse-idx false exit then + + inc-parse-idx + delim? if + pop-parse-idx + true + else + pop-parse-idx + false + then +; + +: str-equiv? ( str -- bool ) + + push-parse-idx + + true -rot + + swap dup rot + swap + + do + i @ nextchar <> if + drop false + leave + then + + inc-parse-idx + loop + + delim? false = if drop false then + + pop-parse-idx +; + +: character? ( -- bool ) + nextchar [char] # <> if false exit then + + push-parse-idx + inc-parse-idx + + nextchar [char] \ <> if pop-parse-idx false exit then + + inc-parse-idx + + S" newline" str-equiv? if pop-parse-idx true exit then + S" space" str-equiv? if pop-parse-idx true exit then + S" tab" str-equiv? if pop-parse-idx true exit then + + charavailable? false = if pop-parse-idx false exit then + + pop-parse-idx true +; + : readnum ( -- num-atom ) minus? dup if - 1 parse-idx +! + inc-parse-idx then 0 begin digit? while 10 * nextchar [char] 0 - + - 1 parse-idx +! + inc-parse-idx repeat swap if negate then @@ -100,73 +189,124 @@ variable parse-str number-type ; -\ Parse a counted string into a scheme expression +: readbool ( -- bool-atom ) + inc-parse-idx + + nextchar [char] f = if + false + else + true + then + + inc-parse-idx + + boolean-type +; + +: readchar ( -- char-atom ) + inc-parse-idx + inc-parse-idx + + S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then + S" space" str-equiv? if 5 parse-idx +! bl character-type exit then + S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then + + nextchar character-type + + inc-parse-idx +; + +\ Parse a scheme expression : read ( -- obj ) eatspaces + number? if readnum exit then - ." Error parsing string at character" parse-idx ? ." . Aborting." cr + boolean? if + readbool + exit + then + + character? if + readchar + exit + then + + eof? if + bold fg blue ." Moriturus te saluto." reset-term ." ok" cr + quit + then + + bold fg red ." Error parsing string starting at character '" + nextchar emit + ." '. Aborting." reset-term cr abort ; \ ---- Eval ---- : self-evaluating? ( obj -- obj bool ) - number-type istype? ; + number-type istype? if true exit then + boolean-type istype? if true exit then + character-type istype? if true exit then + false ; : eval self-evaluating? if exit then - ." Error evaluating expression - unrecognized type. Aborting." cr + bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr abort ; \ ---- Print ---- -: print ( obj -- ) - number-type istype? if - drop . +: printnum ( numobj -- ) drop . ; + +: printbool ( numobj -- ) + drop if + ." #t" + else + ." #f" then ; -\ ---- REPL ---- - -create repl-buffer 161 allot -repl-buffer parse-str ! +: printchar ( charobj -- ) + drop + case + 9 of ." #\tab" endof + bl of ." #\space" endof + '\n' of ." #\newline" endof + + dup ." #\" emit + endcase +; -: getline - repl-buffer 1+ 160 expect cr span @ repl-buffer ! ; +: print ( obj -- ) + ." ; " + number-type istype? if printnum exit then + boolean-type istype? if printbool exit then + character-type istype? if printchar exit then +; -: eof? - repl-buffer @ 0= if false exit then - repl-buffer 1+ @ 4 <> if false exit then - true ; +\ ---- REPL ---- : repl cr ." Welcome to scheme.forth.jl!" cr ." Use Ctrl-D to exit." cr - begin - cr bold fg green ." => " reset-term - getline - - eof? if - fg blue ." Moriturus te saluto." reset-term - exit - then + empty-parse-str - repl-buffer @ 0> if - 0 parse-idx ! - read - eval - print - then + begin + cr bold fg green ." > " reset-term + read + eval + fg cyan print reset-term again ;