X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=e69c63d7c902b640e32d826ef24969f68b1e726e;hb=d40d4d337456d3a096749cc4dcf23f86944f325f;hp=915edbad79021f817a5d24dffdd8fa6fe89136c3;hpb=95c071f1ce6af0571791b2e8b885780182982dff;p=scheme.forth.jl.git diff --git a/scheme.4th b/scheme.4th index 915edba..e69c63d 100644 --- a/scheme.4th +++ b/scheme.4th @@ -4,14 +4,20 @@ scheme definitions include term-colours.4th include defer-is.4th +\ ------ Types ------ + 0 constant number-type 1 constant boolean-type 2 constant character-type -3 constant nil-type -4 constant pair-type +3 constant string-type +4 constant nil-type +5 constant pair-type +6 constant symbol-type : istype? ( obj -- obj b ) over = ; +\ ------ Memory ------ + 100 constant N create car-cells N allot create car-type-cells N allot @@ -32,6 +38,32 @@ variable nextfree 1 nextfree +! ; +: car ( pair-obj -- car-obj ) + drop + dup car-cells + @ swap + car-type-cells + @ +; + +: cdr ( pair-obj -- car-obj ) + drop + dup cdr-cells + @ swap + cdr-type-cells + @ +; + +: nil 0 nil-type ; + +: objvar create 0 , 0 , ; + +: value@ ( objvar -- val ) @ ; +: type@ ( objvar -- type ) 1+ @ ; +: value! ( newval objvar -- ) ! ; +: type! ( newtype objvar -- ) 1+ ! ; +: setobj ( newobj objvar -- ) dup rot swap 1+ ! ! ; +: fetchobj ( objvar -- obj ) dup @ swap 1+ @ ; + +objvar symbol-table +nil symbol-table setobj + \ ---- Read ---- variable parse-idx @@ -198,6 +230,32 @@ parse-idx-stack parse-idx-sp ! : pair? ( -- bool ) nextchar [char] ( = ; +: string? ( -- bool ) + nextchar [char] " = ; + +: initial? ( -- bool ) + nextchar [char] A >= nextchar [char] Z <= and if true exit then + nextchar [char] a >= nextchar [char] z <= and if true exit then + nextchar [char] * = if true exit then + nextchar [char] / = if true exit then + nextchar [char] > = if true exit then + nextchar [char] < = if true exit then + nextchar [char] = = if true exit then + nextchar [char] ? = if true exit then + nextchar [char] ! = if true exit then + false +; + +: symbol? ( -- bool ) + initial? if true exit then + nextchar [char] + = + nextchar [char] - = or if + inc-parse-idx + delim? if dec-parse-idx true exit then + dec-parse-idx + then + false +; : readnum ( -- num-atom ) minus? dup if @@ -243,10 +301,51 @@ parse-idx-stack parse-idx-sp ! inc-parse-idx ; +: readstring ( -- charlist ) + nextchar [char] " = if + inc-parse-idx + + delim? false = if + bold fg red + ." No delimiter following right double quote. Aborting." cr + reset-term abort + then + + dec-parse-idx + + 0 nil-type exit + then + + nextchar [char] \ = if + inc-parse-idx + nextchar case + [char] n of '\n' endof + [char] " of [char] " endof + [char] \ + endcase + else + nextchar + then + inc-parse-idx character-type + + recurse + + cons +; + +: readsymbol ( -- charlist ) + delim? if nil exit then + + nextchar inc-parse-idx character-type + + recurse + + cons +; + defer read : readpair ( -- obj ) - inc-parse-idx eatspaces \ Empty lists @@ -259,7 +358,9 @@ defer read reset-term abort then - nil-type exit + dec-parse-idx + + 0 nil-type exit then \ Read first pair element @@ -277,16 +378,17 @@ defer read then eatspaces read - else recurse then + eatspaces + cons ; \ Parse a scheme expression -: (read) ( -- obj ) +:noname ( -- obj ) eatspaces @@ -305,8 +407,46 @@ defer read exit then + string? if + inc-parse-idx + readstring + drop string-type + + nextchar [char] " <> if + bold red ." Missing closing double-quote." reset-term cr + abort + then + + inc-parse-idx + exit + then + + symbol? if + readsymbol + drop symbol-type + 2dup + symbol-table fetch + cons + symbol-table set + exit + then + pair? if + inc-parse-idx + + eatspaces + readpair + + eatspaces + + nextchar [char] ) <> if + bold red ." Missing closing paren." reset-term cr + abort + then + + inc-parse-idx + exit then @@ -319,18 +459,14 @@ defer read nextchar emit ." '. Aborting." reset-term cr abort -; -' (read) is read +; is read \ ---- Eval ---- : self-evaluating? ( obj -- obj bool ) - number-type istype? if true exit then - boolean-type istype? if true exit then - character-type istype? if true exit then - nil-type istype? if true exit then - false ; + true \ everything self-evaluating for now +; : eval self-evaluating? if @@ -343,7 +479,7 @@ defer read \ ---- Print ---- -: printnum ( numobj -- ) drop . ; +: printnum ( numobj -- ) drop 0 .R ; : printbool ( numobj -- ) drop if @@ -364,16 +500,56 @@ defer read endcase ; +: (printstring) ( stringobj -- ) + nil-type istype? if 2drop exit then + + 2dup car drop dup + case + '\n' of ." \n" drop endof + [char] \ of ." \\" drop endof + [char] " of [char] \ emit [char] " emit drop endof + emit + endcase + + cdr recurse +; +: printstring ( stringobj -- ) + [char] " emit + (printstring) + [char] " emit ; + +: printsymbol ( symbolobj -- ) + nil-type istype? if 2drop exit then + + 2dup car drop emit + cdr recurse +; + : printnil ( nilobj -- ) - drop ." ()" ; + 2drop ." ()" ; + +defer print +: printpair ( pairobj -- ) + 2dup + car print + cdr + nil-type istype? if 2drop exit then + pair-type istype? if space recurse exit then + ." . " print +; -: print ( obj -- ) - ." ; " +:noname ( obj -- ) number-type istype? if printnum exit then boolean-type istype? if printbool exit then character-type istype? if printchar exit then + string-type istype? if printstring exit then + symbol-type istype? if printsymbol exit then nil-type istype? if printnil exit then -; + pair-type istype? if ." (" printpair ." )" exit then + + bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr + abort +; is print \ ---- REPL ---- @@ -387,7 +563,7 @@ defer read cr bold fg green ." > " reset-term read eval - fg cyan print reset-term + fg cyan ." ; " print reset-term again ;