X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=08a72b5380f53be0a757e46b54b2f3a6f2e41abe;hb=7f58e8a0232663cd99ea18fd249d1e590ceb6fff;hp=5fe8b3eb07663763be2ee6a3f9a0b4ca06253f9b;hpb=96099b1d09aae7cf167efca9fd04406750eb7157;p=scheme.forth.jl.git diff --git a/scheme.4th b/scheme.4th index 5fe8b3e..08a72b5 100644 --- a/scheme.4th +++ b/scheme.4th @@ -3,176 +3,238 @@ vocabulary scheme scheme definitions -\ Cons cell memory -1000 constant memsize -create car memsize allot -create cdr memsize allot -create types memsize allot +include term-colours.4th -0 constant symbol-type -1 constant int-type -2 constant list-type -3 constant bool-type +0 constant number-type +1 constant boolean-type +2 constant character-type +: istype? ( obj -- obj b ) + over = ; -variable nextfree -0 nextfree ! +\ ---- Read ---- -: stack - create here 1+ , allot ; +variable parse-idx +variable stored-parse-idx +create parse-str 161 allot +variable parse-str-span +: append-newline + '\n' parse-str parse-str-span @ + ! + 1 parse-str-span +! ; -: push ( st v -- ) - over @ ! - 1 swap +! -; +: empty-parse-str + 0 parse-str-span ! + 0 parse-idx ! ; -: pop ( st -- v ) - dup @ ( s0 sp ) - 1- ( so sp' ) +: getline + parse-str 160 expect cr + span @ parse-str-span ! + append-newline + 0 parse-idx ! ; - 2dup = abort" Stack underflow." - - dup @ ( s0 sp' v ) - -rot swap ( v sp' s0 ) - ! -; +: inc-parse-idx + 1 parse-idx +! ; -100 stack parse-stack -variable parse-idx -variable parse-str +: dec-parse-idx + 1 parse-idx -! ; +: store-parse-idx + parse-idx @ stored-parse-idx ! ; -: inc-parse-idx parse-idx +! ; -: dec-parse-idx parse-idx -! ; +: restore-parse-idx + stored-parse-idx @ parse-idx ! ; -: ?charavailable ( -- bool ) - parse-str @ @ parse-idx @ > -; +: charavailable? ( -- bool ) + 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 ) +: whitespace? ( -- bool ) nextchar BL = - nextchar '\n' = or -; + nextchar '\n' = or ; -: ?delim ( -- bool ) - ?whitespace +: eof? ( -- bool ) + nextchar 4 = ; + +: delim? ( -- bool ) + whitespace? nextchar [char] ( = or nextchar [char] ) = or ; : eatspaces begin - ?whitespace + whitespace? while - 1 parse-idx +! + inc-parse-idx repeat ; -: parsebool - - nextchar emit cr - trace +: digit? ( -- bool ) + nextchar [char] 0 >= + nextchar [char] 9 <= + and ; - false - nextchar [char] # <> if exit then +: minus? ( -- bool ) + nextchar [char] - = ; - 1 inc-parse-idx - - nextchar dup [char] t = swap [char] f = or - not if - 1 dec-parse-idx +: number? ( -- bool ) + digit? minus? or false = if + false exit then - 1 inc-parse-idx + store-parse-idx + inc-parse-idx - ?delim not if - 2 dec-parse-idx - exit + begin digit? while + inc-parse-idx + repeat + + delim? charavailable? false = or if + restore-parse-idx + true + else + restore-parse-idx + false then ; -: parsetoken +: boolean? ( -- bool ) + nextchar [char] # <> if false exit then - eatspaces + store-parse-idx + inc-parse-idx - \ Parens + nextchar [char] t <> + nextchar [char] f <> + and if restore-parse-idx false exit then - nextchar [char] ( = if - \ todo - exit + restore-parse-idx + true +; + +: character? ( -- bool ) + nextchar [char] # <> if false exit then + + store-parse-idx + inc-parse-idx + + nextchar [char] \ <> if restore-parse-idx false exit then + + inc-parse-idx + + charavailable? false = if restore-parse-idx false exit then + + restore-parse-idx true +; + +: readnum ( -- num-atom ) + minus? dup if + inc-parse-idx + then + + 0 + + begin digit? while + 10 * nextchar [char] 0 - + + inc-parse-idx + repeat + + swap if negate then + + number-type +; + +: readbool ( -- bool-atom ) + inc-parse-idx + + nextchar [char] f = if + false + else + true then - nextchar [char] ) = if - \ todo + inc-parse-idx + + boolean-type +; + +\ Parse a scheme expression +: read ( -- obj ) + + eatspaces + + number? if + readnum exit then - parsebool if + boolean? if + readbool exit - exit -; + then -\ Parse a counted string into a scheme expression -: parseexp ( straddr n -- exp ) - 0 parse-idx ! + eof? if + bold fg blue ." Moriturus te saluto." reset-term ." ok" cr + quit + then - begin - parsetoken - nextchar 0 = - until + bold fg red ." Error parsing string starting at character '" + nextchar emit + ." '. Aborting." reset-term cr + abort ; -\ ---- REPL ---- +\ ---- Eval ---- -: escape 27 emit [char] [ emit ; -: escape-end [char] m emit ; +: self-evaluating? ( obj -- obj bool ) + number-type istype? if true exit then + boolean-type istype? if true exit then + false ; -: set-term-colour - escape [char] 3 emit [char] 0 + emit escape-end -; +: eval + self-evaluating? if + exit + then -: reset-term - escape [char] 0 escape-end + bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr + abort ; -: colour - create , -does> - @ set-term-colour +\ ---- Print ---- + +: printnum ( numobj -- ) drop . ; + +: printbool ( numobj -- ) + drop if + ." #t" + else + ." #f" + then ; -1 colour red -2 colour green -3 colour yellow -4 colour blue -5 colour magenta -6 colour cyan -7 colour white +: print ( obj -- ) + ." ; " + number-type istype? if printnum exit then + boolean-type istype? if printbool exit then +; -create repl-buffer 161 allot +\ ---- REPL ---- : repl - repl-buffer parse-str ! + cr ." Welcome to scheme.forth.jl!" cr + ." Use Ctrl-D to exit." cr - cr + empty-parse-str begin - green ." => " white - - repl-buffer 1+ 160 expect cr - span @ repl-buffer ! - - parseexp - \ eval + cr bold fg green ." > " reset-term + read + eval + fg cyan print reset-term again ;