X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=4ccf7d83049a0816dd1ac71b7d7a5a17a7da69f4;hb=f81ffb05496dc3490c0c7469017d9c7ba7c0113a;hp=d6b362158a612082750f44e0a725c56837b8ccf7;hpb=61f902750c854d52bc37a5903e07b7e84f7081c4;p=scheme.forth.jl.git diff --git a/scheme.4th b/scheme.4th index d6b3621..4ccf7d8 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-warning ( addr count -- ) + bold fg red + ." Exception: " + type + reset-term ; + +: throw" immediate + [compile] s" + + ['] rot , ['] dup , + + [compile] if + ['] -rot , + ['] display-warning , + [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 ; @@ -262,15 +296,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 +390,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 +400,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 +450,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 +471,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 +998,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 @@ -1022,19 +1069,34 @@ parse-idx-stack parse-idx-sp ! : make-lambda ( params body -- lambda-exp ) lambda-symbol -2rot cons cons ; -: definition-var ( obj -- var ) - cdr car - symbol-type istype? false = if car then +( Handles iterative expansion of defines in + terms of nested lambdas. Most Schemes only + handle one iteration of expansion! ) +: definition-var-val ( obj -- var val ) + + cdr 2dup cdr 2swap car ( val var ) + + 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 + + 2swap car ; -: definition-val ( obj -- val ) - 2dup cdr car symbol-type istype? if - 2drop - cdr cdr car - else - cdr 2swap cdr cdr - make-lambda - then +: eval-definition ( obj env -- res ) + 2dup 2rot ( env env obj ) + definition-var-val ( env env var val ) + 2rot eval ( env var val ) + + 2rot ( var val env ) + define-var + + ok-symbol ; : assignment? ( obj -- obj bool ) @@ -1046,20 +1108,6 @@ parse-idx-stack parse-idx-sp ! : assignment-val ( obj -- val ) cdr cdr car ; -: eval-definition ( obj env -- res ) - 2swap - 2over 2over ( env obj env obj ) - definition-val 2swap ( env obj valexp env ) - eval ( env obj val ) - - 2swap definition-var 2swap ( env var val ) - - 2rot ( var val env ) - define-var - - ok-symbol -; - : eval-assignment ( obj env -- res ) 2swap 2over 2over ( env obj env obj ) @@ -1213,7 +1261,14 @@ hide env ( Ensure terminating symbol arg name is handled specially to allow for variadic procedures. ) : flatten-proc-args ( argvals argnames -- argvals' argnames' ) - nil? if exit then + nil? if + 2over nil? false = if + recoverable-exception throw" Too many arguments for compound procedure." + else + 2drop + then + exit + then symbol-type istype? if nil cons @@ -1223,7 +1278,15 @@ hide env exit then - 2over cdr 2over cdr + 2over + nil? if + recoverable-exception throw" Too few arguments for compound procedure." + else + cdr + then + + 2over cdr + recurse ( argvals argnames argvals'' argnames'' ) 2rot car 2swap cons ( argvals argvals'' argnames' ) 2rot car 2rot cons ( argnames' argvals' ) @@ -1252,8 +1315,7 @@ 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 ; @@ -1343,9 +1405,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 @@ -1365,8 +1425,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 \ }}} @@ -1455,8 +1514,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 \ }}} @@ -1618,6 +1676,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 @@ -1627,19 +1704,18 @@ variable gc-stack-depth enable-gc begin - cr bold fg green ." > " reset-term - read-console - - 2dup EOF character-type objeq? if - 2drop - bold fg blue ." Moriturus te saluto." reset-term cr - exit - then + ['] repl-body catch + case + recoverable-exception of false endof + unrecoverable-exception of true endof - global-env obj@ eval + \ Rethrow anything else: + throw - fg cyan ." ; " print reset-term - again + \ If we're still here, loop again + false + endcase + until ; forth definitions