X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=ea02cd513b424fd72efede52139568e87c758204;hb=26a971100b29dee243a42096d52d69ca518905ea;hp=5ad37c6c98cd09ecf41b2235b80731a85a02e62b;hpb=2ab189727b2f1502367dae83dfaf931e3eab1684;p=scheme.forth.jl.git diff --git a/scheme.4th b/scheme.4th index 5ad37c6..ea02cd5 100644 --- a/scheme.4th +++ b/scheme.4th @@ -7,38 +7,67 @@ 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 -: store-parse-idx - parse-idx @ dummy-parse-idx ! ; +create parse-idx-stack 10 allot +variable parse-idx-sp +parse-idx-stack parse-idx-sp ! -: restore-parse-idx - dummy-parse-idx @ parse-idx ! ; +: 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 -! + + parse-idx-sp @ @ parse-idx ! ; -variable parse-str + +: 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 ! ; + +: inc-parse-idx + 1 parse-idx +! ; + +: 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? @@ -50,7 +79,7 @@ variable parse-str begin whitespace? while - 1 parse-idx +! + inc-parse-idx repeat ; @@ -68,18 +97,18 @@ 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 ; @@ -87,26 +116,72 @@ variable parse-str : boolean? ( -- bool ) nextchar [char] # <> if false exit then - 1 parse-idx +! + push-parse-idx + inc-parse-idx nextchar [char] t <> nextchar [char] f <> - and if 1 parse-idx -! false exit then + 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 - 1 parse-idx -! true + + swap dup rot + swap + do + i @ nextchar <> if + drop false + leave + then + + inc-parse-idx + loop + + delim? <> 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 true exit then + S" space" str-equiv? if true exit then + S" tab" str-equiv? if 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 @@ -115,7 +190,7 @@ variable parse-str ; : readbool ( -- bool-atom ) - 1 parse-idx +! + inc-parse-idx nextchar [char] f = if false @@ -123,10 +198,25 @@ variable parse-str true then + inc-parse-idx + boolean-type ; -\ Parse a counted string into a scheme expression +: readchar ( -- char-atom ) + inc-parse-idx + inc-parse-idx + + S" newline" str-equiv? if '\n' character-type exit then + S" space" str-equiv? if bl character-type exit then + S" tab" str-equiv? if 9 character-type exit then + + nextchar character-type + + inc-parse-idx +; + +\ Parse a scheme expression : read ( -- obj ) eatspaces @@ -141,6 +231,16 @@ variable parse-str 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 @@ -166,6 +266,7 @@ variable parse-str \ ---- Print ---- : printnum ( numobj -- ) drop . ; + : printbool ( numobj -- ) drop if ." #t" @@ -174,44 +275,35 @@ variable parse-str then ; +: printchar ( charobj -- ) + drop + case + 9 of ." #\tab" endof + bl of ." #\space" endof + '\n' of ." #\newline" endof + endcase +; + : print ( obj -- ) ." ; " - number-type istype? if ." => " printnum exit then - boolean-type istype? if ." => " printbool exit then + number-type istype? if printnum exit then + boolean-type istype? if printbool exit then + character-type istype? if printchar exit then ; \ ---- REPL ---- -create repl-buffer 161 allot -repl-buffer parse-str ! - -: getline - repl-buffer 1+ 160 expect span @ repl-buffer ! ; - -: eof? - repl-buffer @ 0= if false exit then - repl-buffer 1+ @ 4 <> if false exit then - true ; - : repl cr ." Welcome to scheme.forth.jl!" cr ." Use Ctrl-D to exit." cr + empty-parse-str + begin cr bold fg green ." > " reset-term - getline - - eof? if - bold fg blue ." Moriturus te saluto." reset-term - exit - then - - repl-buffer @ 0> if - 0 parse-idx ! - read - eval - fg cyan print reset-term - then + read + eval + fg cyan print reset-term again ;