X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scheme.forth.jl.git;a=blobdiff_plain;f=scheme.4th;h=f8dd0899d0e02aac9094648a03be84f1f10ee6f6;hp=24937a21c16619907ccde4f37fd79338c365dd37;hb=3eaf389aa81bcfbf8dd64c89520925413d5c2390;hpb=050cc9a7e651ba8eacb054283307f4d06141c302 diff --git a/scheme.4th b/scheme.4th index 24937a2..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? ; @@ -1112,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 ; @@ -1216,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 @@ -1234,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 @@ -1270,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 ) @@ -1302,6 +1431,11 @@ hide env exit then + quasiquote? if + 2swap eval-quasiquote + exit + then + variable? if 2swap lookup-var exit @@ -1381,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 \ }}} @@ -1413,7 +1546,7 @@ hide env ; : (printstring) ( stringobj -- ) - nil-type istype? if 2drop exit then + nil? if 2drop exit then 2dup car drop dup case @@ -1458,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 @@ -1471,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 \ }}} @@ -1634,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 @@ -1643,19 +1797,14 @@ 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 - - fg cyan ." ; " print reset-term - again + throw false + endcase + until ; forth definitions