X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scheme.forth.jl.git;a=blobdiff_plain;f=scheme.4th;h=f8dd0899d0e02aac9094648a03be84f1f10ee6f6;hp=8c5b159026782db9952cce2f45fce954e670e49b;hb=3eaf389aa81bcfbf8dd64c89520925413d5c2390;hpb=7bea53082737088667ae438fcdba69137c43674d

diff --git a/scheme.4th b/scheme.4th
index 8c5b159..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? ;
 
@@ -239,7 +268,7 @@ objvar symbol-table
 ;
 
 
-: cstr>charlist ( addr n -- symbol-obj )
+: cstr>charlist ( addr n -- charlist )
     dup 0= if
         2drop nil
     else
@@ -256,27 +285,24 @@ objvar symbol-table
     count
 
     cstr>charlist
-    drop symbol-type
-
-    2dup
-
-    symbol-table obj@
-    cons
-    symbol-table obj!
+    charlist>symbol
 
     create swap , ,
     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
 
 \ }}}
 
@@ -359,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
 ;
 
@@ -369,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
 ;
 
@@ -402,6 +428,49 @@ objvar global-env
 nil nil nil extend-env
 global-env obj!
 
+\ }}}
+
+\ ---- Primitives ---- {{{
+
+: make-primitive ( cfa -- )
+    bl word
+    count
+
+    \ 2dup ." Defining primitive " type ." ..." cr
+
+    cstr>charlist
+    charlist>symbol
+  
+    rot primitive-proc-type ( var prim )
+    global-env obj@ define-var
+;
+
+: ensure-arg-count ( args n -- )
+    dup 0= if
+        drop nil objeq? false = if
+            recoverable-exception throw" Too many arguments for primitive procedure."
+        then
+    else
+        -rot nil? if
+            recoverable-exception throw" Too few arguments for primitive procedure."
+        then
+        
+        cdr rot 1- recurse
+    then
+;
+
+: arg-type-error
+            bold fg red ." Incorrect argument type." reset-term cr
+            abort
+;
+
+: ensure-arg-type ( arg type -- arg )
+    istype? false = if
+        recoverable-exception throw" Incorrect argument type for primitive procedure."
+    then
+;
+
+
 \ }}}
 
 \ ---- Macros ---- {{{
@@ -924,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
@@ -969,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? ;
@@ -980,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 )
@@ -1004,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 )
@@ -1069,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 ;
@@ -1171,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
@@ -1181,17 +1362,25 @@ 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
 ;
 
-: apply ( proc argvals )
+: apply ( proc argvals -- result )
         2swap dup case
             primitive-proc-type of
-                drop execute
+                drop execute     
             endof
 
             compound-proc-type of
@@ -1210,11 +1399,24 @@ hide env
                 R> drop ['] eval goto-deferred  \ Tail call optimization
             endof
 
-            bold fg red ." Object not applicable. Aboring." 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 )
+    -2rot 2dup procedure-params ( procbody expbody proc argnames )
+    -2rot procedure-env ( procbody argnames expbody procenv )
+    
+    -2rot 2swap
+    flatten-proc-args
+    2swap 2rot
+
+    extend-env eval-sequence eval
+;
+
 :noname ( obj env -- result )
     2swap
 
@@ -1229,6 +1431,11 @@ hide env
         exit
     then
 
+    quasiquote? if
+        2swap eval-quasiquote
+        exit
+    then
+
     variable? if
         2swap lookup-var
         exit
@@ -1280,35 +1487,35 @@ hide env
     application? if
 
         2over 2over ( env exp env exp )
-        operator 2dup ( env exp env opname opname )
+        operator ( env exp env opname )
 
-        lookup-macro nil? if
-            \ Regular function application
+        2dup lookup-macro nil? false = if
+             \ Macro function evaluation
+
+            ( env exp env opname mproc )
+            2swap 2drop -2rot 2drop cdr ( env mproc body )
+
+            macro-expand
+
+            2swap
+            ['] eval goto-deferred
+        else
+           \ Regular function application
 
             2drop ( env exp env opname )
 
             2swap eval ( env exp proc )
+
             -2rot ( proc env exp )
             operands 2swap ( proc operands env )
             list-of-vals ( proc argvals )
 
             apply
-        else
-            \ Macro function evaluation
-
-            ." Macro eval"
-
-            ( env exp env opname mproc )
-            2swap 2drop -2rot 2drop cdr ( env mproc body )
-
-            \ TODO: evaluate macro procedure on expression body
-            ." ABORTED: Macros not yet fully implemented!" abort
+            exit
         then
-        exit
     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
 
 \ }}}
@@ -1339,7 +1546,7 @@ hide env
 ;
 
 : (printstring) ( stringobj -- )
-    nil-type istype? if 2drop exit then
+    nil? if 2drop exit then
 
     2dup car drop dup
     case
@@ -1384,6 +1591,9 @@ hide env
 : printnone ( noneobj -- )
     2drop ." Unspecified return value" ;
 
+: printport ( port -- )
+    2drop ." <port>" ;
+
 :noname ( obj -- )
     fixnum-type istype? if printfixnum exit then
     realnum-type istype? if printrealnum exit then
@@ -1397,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
 
 \ }}}
@@ -1507,61 +1716,6 @@ variable gc-stack-depth
 
 \ }}}
 
-\ ---- Primitives ---- {{{
-
-: make-primitive ( cfa -- )
-    bl word
-    count
-
-    \ 2dup ." Defining primitive " type ." ..." cr
-
-    cstr>charlist
-    drop symbol-type
-    
-    2dup
-
-    symbol-table obj@
-    cons
-    symbol-table obj!
-
-    rot primitive-proc-type ( var prim )
-    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
-        then
-    else
-        -rot nil? if
-            arg-count-error
-        then
-        
-        cdr rot 1- recurse
-    then
-;
-
-: arg-type-error
-            bold fg red ." Incorrect argument type." reset-term cr
-            abort
-;
-
-: ensure-arg-type ( arg type -- arg )
-    istype? false = if
-        arg-type-error
-    then
-;
-
-include scheme-primitives.4th
-
-\ }}}
-
 \ ---- Loading files ---- {{{
 
 : charlist>cstr ( charlist addr -- n )
@@ -1603,19 +1757,37 @@ include scheme-primitives.4th
     again
 ;
 
-:noname ( args -- finalResult )
-    2dup 1 ensure-arg-count
-    car string-type ensure-arg-type
+\ }}}
+
+\ ---- Standard Library ---- {{{
 
-    drop pair-type
-    pad charlist>cstr
-    pad swap load
-; make-primitive load
+    include scheme-primitives.4th
 
+    s" scheme-library.scm" load 2drop
+    
 \ }}}
 
 \ ---- 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
@@ -1625,19 +1797,14 @@ include scheme-primitives.4th
     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