X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scheme.forth.jl.git;a=blobdiff_plain;f=scheme.4th;h=f8dd0899d0e02aac9094648a03be84f1f10ee6f6;hp=3728257eb997f7203c541dcadd0c885a0da1edec;hb=3eaf389aa81bcfbf8dd64c89520925413d5c2390;hpb=9be58bf752f3b2c5b0b6c6880f77b482e9da0ffd diff --git a/scheme.4th b/scheme.4th index 3728257..f8dd089 100644 --- a/scheme.4th +++ b/scheme.4th @@ -3,6 +3,7 @@ scheme definitions include term-colours.4th include defer-is.4th +include catch-throw.4th include float.4th include debugging.4th @@ -13,7 +14,7 @@ defer print defer collect-garbage -\ ------ Types ------ +\ ---- Types ---- {{{ variable nexttype 0 nexttype ! @@ -37,6 +38,41 @@ make-type fileport-type : istype? ( obj type -- obj bool ) over = ; +\ }}} + +\ ---- Exceptions ---- {{{ + +variable nextexception +1 nextexception ! +: make-exception + create nextexception @ , + 1 nextexception +! + does> @ ; + +make-exception recoverable-exception +make-exception unrecoverable-exception + +: display-exception-msg ( addr count -- ) + bold fg red + ." Exception: " + type + reset-term ; + +: throw" immediate + [compile] s" + + ['] rot , ['] dup , + + [compile] if + ['] -rot , + ['] display-exception-msg , + [compile] then + + ['] throw , +; + +\ }}} + \ ---- List-structured memory ---- {{{ 10000 constant scheme-memsize @@ -65,9 +101,7 @@ variable nextfree then nextfree @ scheme-memsize >= if - fg red bold - ." Out of memory! Aborting." - reset-term abort + unrecoverable-exception throw s" Out of memory!" then ; @@ -105,11 +139,6 @@ variable nextfree cdr-cells + ! ; -: caar car car ; -: cadr cdr car ; -: cdar car cdr ; -: cddr cdr cdr ; - : nil 0 nil-type ; : nil? nil-type istype? ; @@ -262,15 +291,18 @@ objvar symbol-table does> dup @ swap 1+ @ ; -create-symbol quote quote-symbol -create-symbol define define-symbol -create-symbol define-macro define-macro-symbol -create-symbol set! set!-symbol -create-symbol ok ok-symbol -create-symbol if if-symbol -create-symbol lambda lambda-symbol -create-symbol λ λ-symbol -create-symbol begin begin-symbol +create-symbol quote quote-symbol +create-symbol quasiquote quasiquote-symbol +create-symbol unquote unquote-symbol +create-symbol unquote-splicing unquote-splicing-symbol +create-symbol define define-symbol +create-symbol define-macro define-macro-symbol +create-symbol set! set!-symbol +create-symbol ok ok-symbol +create-symbol if if-symbol +create-symbol lambda lambda-symbol +create-symbol λ λ-symbol +create-symbol begin begin-symbol \ }}} @@ -353,7 +385,7 @@ hide vals get-vars-vals if 2swap 2drop car else - bold fg red ." Tried to read unbound variable." reset-term cr abort + recoverable-exception throw" Tried to read unbound variable." then ; @@ -363,7 +395,7 @@ hide vals 2swap 2drop ( val vals ) set-car! else - bold fg red ." Tried to set unbound variable." reset-term cr abort + recoverable-exception throw" Tried to set unbound variable." then ; @@ -413,19 +445,14 @@ global-env obj! global-env obj@ define-var ; -: arg-count-error - bold fg red ." Incorrect argument count." reset-term cr - abort -; - : ensure-arg-count ( args n -- ) dup 0= if drop nil objeq? false = if - arg-count-error + recoverable-exception throw" Too many arguments for primitive procedure." then else -rot nil? if - arg-count-error + recoverable-exception throw" Too few arguments for primitive procedure." then cdr rot 1- recurse @@ -439,7 +466,7 @@ global-env obj! : ensure-arg-type ( arg type -- arg ) istype? false = if - arg-type-error + recoverable-exception throw" Incorrect argument type for primitive procedure." then ; @@ -966,6 +993,21 @@ parse-idx-stack parse-idx-sp ! quote-symbol recurse nil cons cons exit then + nextchar [char] ` = if + inc-parse-idx + quasiquote-symbol recurse nil cons cons exit + then + + nextchar [char] , = if + inc-parse-idx + nextchar [char] @ = if + inc-parse-idx + unquote-splicing-symbol recurse nil cons cons exit + else + unquote-symbol recurse nil cons cons exit + then + then + eof? if EOF character-type inc-parse-idx @@ -1011,7 +1053,96 @@ parse-idx-stack parse-idx-sp ! quote-symbol tagged-list? ; : quote-body ( quote-obj -- quote-body-obj ) - cadr ; + cdr car ; + +: quasiquote? ( obj -- obj bool ) + quasiquote-symbol tagged-list? ; + +: unquote? ( obj -- obj bool ) + unquote-symbol tagged-list? ; + +: unquote-splicing? ( obj -- obj bool ) + unquote-splicing-symbol tagged-list? ; + +: eval-unquote ( env obj -- res ) + cdr ( env args ) + + nil? if + recoverable-exception throw" no arguments to unquote." + then + + 2dup cdr + nil? false = if + recoverable-exception throw" too many arguments to unquote." + then + + 2drop car 2swap eval +; + +( Create a new list from elements of l1 consed on to l2 ) +: join-lists ( l2 l1 -- l3 ) + nil? if 2drop exit then + + 2dup car + -2rot cdr + recurse cons +; + +defer eval-quasiquote-item +: eval-quasiquote-pair ( env obj -- res ) + 2over 2over ( env obj env obj ) + + cdr eval-quasiquote-item + + -2rot car ( cdritem env objcar ) + + unquote-splicing? if + eval-unquote ( cdritems caritem ) + + 2swap nil? if + 2drop + else + 2swap join-lists + then + else + eval-quasiquote-item ( cdritems caritem ) + 2swap cons + then + +; + +:noname ( env obj ) + nil? if + 2swap 2drop exit + then + + unquote? if + eval-unquote exit + then + + pair-type istype? if + eval-quasiquote-pair exit + then + + 2swap 2drop +; is eval-quasiquote-item + +: eval-quasiquote ( obj env -- res ) + 2swap cdr ( env args ) + + nil? if + recoverable-exception throw" no arguments to quasiquote." + then + + 2dup cdr ( env args args-cdr ) + nil? false = if + recoverable-exception throw" too many arguments to quasiquote." + then + + 2drop car ( env arg ) + + eval-quasiquote-item +; : variable? ( obj -- obj bool ) symbol-type istype? ; @@ -1022,43 +1153,25 @@ parse-idx-stack parse-idx-sp ! : make-lambda ( params body -- lambda-exp ) lambda-symbol -2rot cons cons ; -( Handles recursive expansion of defines in +( Handles iterative expansion of defines in terms of nested lambdas. Most Schemes only - handle one level of expansion! ) -: (definition-var-val) ( val var -- val' var' ) - symbol-type istype? if 2swap car 2swap exit then + handle one iteration of expansion! ) +: definition-var-val ( obj -- var val ) - 2dup cdr 2swap car - symbol-type istype? if - 2swap ( body procname procargs ) - 2rot ( procname procargs body ) - make-lambda ( procname lambda-exp ) - 2swap - exit - then + cdr 2dup cdr 2swap car ( val var ) - ( body procargs nextval ) - -2rot 2swap ( nextval procargs body ) - make-lambda nil cons ( nextval lambda-exp ) - 2swap ( lambda-exp nextval ) - recurse -; + begin + symbol-type istype? false = + while + 2dup cdr 2swap car ( val formals var' ) + -2rot 2swap ( var' formals val ) + make-lambda nil cons ( var' val' ) + 2swap ( val' var' ) + repeat -: definition-var-val ( obj -- var val ) - cdr 2dup cdr 2swap car - (definition-var-val) - 2swap + 2swap car ; -: assignment? ( obj -- obj bool ) - set!-symbol tagged-list? ; - -: assignment-var ( obj -- var ) - cdr car ; - -: assignment-val ( obj -- val ) - cdr cdr car ; - : eval-definition ( obj env -- res ) 2dup 2rot ( env env obj ) definition-var-val ( env env var val ) @@ -1069,7 +1182,16 @@ parse-idx-stack parse-idx-sp ! ok-symbol ; + +: assignment? ( obj -- obj bool ) + set!-symbol tagged-list? ; + +: assignment-var ( obj -- var ) + cdr car ; +: assignment-val ( obj -- val ) + cdr cdr car ; + : eval-assignment ( obj env -- res ) 2swap 2over 2over ( env obj env obj ) @@ -1121,10 +1243,10 @@ hide env : if-consequent ( ifobj -- conseq ) cdr cdr car ; -: if-alternative ( ifobj -- alt|false ) +: if-alternative ( ifobj -- alt|none ) cdr cdr cdr nil? if - 2drop false + 2drop none else car then ; @@ -1225,8 +1347,7 @@ hide env : flatten-proc-args ( argvals argnames -- argvals' argnames' ) nil? if 2over nil? false = if - bold fg red ." Too many arguments supplied to compound method. Aborting." reset-term cr - abort + recoverable-exception throw" Too many arguments for compound procedure." else 2drop then @@ -1243,8 +1364,7 @@ hide env 2over nil? if - bold fg red ." Too few arguments supplied to compound method. Aborting." reset-term cr - abort + recoverable-exception throw" Too few arguments for compound procedure." else cdr then @@ -1279,11 +1399,11 @@ hide env R> drop ['] eval goto-deferred \ Tail call optimization endof - bold fg red ." Object not applicable. Aborting." reset-term cr - abort + recoverable-exception throw" Object not applicable." endcase ; +( Simply evaluates the given procedure with expbody as its argument. ) : macro-expand ( proc expbody -- result ) 2swap 2dup procedure-body ( expbody proc procbody ) @@ -1311,6 +1431,11 @@ hide env exit then + quasiquote? if + 2swap eval-quasiquote + exit + then + variable? if 2swap lookup-var exit @@ -1370,9 +1495,7 @@ hide env ( env exp env opname mproc ) 2swap 2drop -2rot 2drop cdr ( env mproc body ) - 2dup print cr macro-expand - 2dup print cr 2swap ['] eval goto-deferred @@ -1392,8 +1515,7 @@ hide env then then - bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr - abort + recoverable-exception throw" Tried to evaluate object with unknown type." ; is eval \ }}} @@ -1424,7 +1546,7 @@ hide env ; : (printstring) ( stringobj -- ) - nil-type istype? if 2drop exit then + nil? if 2drop exit then 2dup car drop dup case @@ -1469,6 +1591,9 @@ hide env : printnone ( noneobj -- ) 2drop ." Unspecified return value" ; +: printport ( port -- ) + 2drop ." " ; + :noname ( obj -- ) fixnum-type istype? if printfixnum exit then realnum-type istype? if printrealnum exit then @@ -1482,8 +1607,7 @@ hide env compound-proc-type istype? if printcomp exit then none-type istype? if printnone exit then - bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr - abort + recoverable-exception throw" Tried to print object with unknown type." ; is print \ }}} @@ -1645,6 +1769,25 @@ variable gc-stack-depth \ ---- REPL ---- +( REPL calls REPL-BODY in a loop until repl-body returns true. ) +: repl-body ( -- bool ) + cr bold fg green ." > " reset-term + + read-console + + 2dup EOF character-type objeq? if + 2drop + bold fg blue ." Moriturus te saluto." reset-term cr + true exit + then + + global-env obj@ eval + + fg cyan ." ; " print reset-term + + false +; + : repl cr ." Welcome to scheme.forth.jl!" cr ." Use Ctrl-D to exit." cr @@ -1654,19 +1797,14 @@ variable gc-stack-depth enable-gc begin - cr bold fg green ." > " reset-term - read-console + ['] repl-body catch + case + recoverable-exception of false endof + unrecoverable-exception of true endof - 2dup EOF character-type objeq? if - 2drop - bold fg blue ." Moriturus te saluto." reset-term cr - exit - then - - global-env obj@ eval - - fg cyan ." ; " print reset-term - again + throw false + endcase + until ; forth definitions