X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scheme.forth.jl.git;a=blobdiff_plain;f=scheme.4th;h=f8dd0899d0e02aac9094648a03be84f1f10ee6f6;hp=9b940e78a2ceb61c5fe6bf1c1f272ee500f72e28;hb=3eaf389aa81bcfbf8dd64c89520925413d5c2390;hpb=7d3d7e571901f7191ce548600b51e97f30f8a225 diff --git a/scheme.4th b/scheme.4th index 9b940e7..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,19 +1153,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 +1192,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 ) @@ -1111,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 ; @@ -1213,7 +1345,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,21 +1362,21 @@ 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' ) 2swap ; -:noname - \ Dummy apply procedure - \ Should never actually run! - ." Error: Dummy apply procedure executed!" cr -; dup make-primitive apply -objvar dummy-apply-proc -primitive-proc-type dummy-apply-proc obj! - : apply ( proc argvals -- result ) 2swap dup case primitive-proc-type of @@ -1260,11 +1399,11 @@ primitive-proc-type dummy-apply-proc obj! 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 ) @@ -1292,6 +1431,11 @@ primitive-proc-type dummy-apply-proc obj! exit then + quasiquote? if + 2swap eval-quasiquote + exit + then + variable? if 2swap lookup-var exit @@ -1351,49 +1495,27 @@ primitive-proc-type dummy-apply-proc obj! ( 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 - then - - \ Regular function application - - 2drop ( env exp env opname ) - - 2swap eval ( env exp proc ) + else + \ Regular function application - 2dup dummy-apply-proc obj@ objeq? if - 2drop ( env exp ) - cdr 2over 2over car ( env expbody env real-opname ) - 2swap eval ( env expbody proc ) + 2drop ( env exp env opname ) - 2swap cdr - nil? false = if car then ( env proc real-operand ) + 2swap eval ( env exp proc ) - 2rot eval ( proc argvals ) - - pair-type istype? false = if - bold fg red ." Error: apply requires a list of operand arguments." cr - reset-term abort - then + -2rot ( proc env exp ) + operands 2swap ( proc operands env ) + list-of-vals ( proc argvals ) apply exit - then - - -2rot ( proc env exp ) - operands 2swap ( proc operands env ) - list-of-vals ( proc argvals ) - - apply - exit + 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 @@ primitive-proc-type dummy-apply-proc obj! ; : (printstring) ( stringobj -- ) - nil-type istype? if 2drop exit then + nil? if 2drop exit then 2dup car drop dup case @@ -1469,6 +1591,9 @@ primitive-proc-type dummy-apply-proc obj! : 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 @@ primitive-proc-type dummy-apply-proc obj! 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