X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=7c1a31606045a96f092d71327a86c91ddea1e440;hb=167e0b9dcc4de39b9479abcfcc80cc039023e1a7;hp=0a237daf70801753b381cf6cf50f59a377f78232;hpb=1a74d57182085535faef901d6940874bea3ad3c6;p=scheme.forth.jl.git

diff --git a/scheme.4th b/scheme.4th
index 0a237da..7c1a316 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -271,6 +271,7 @@ create-symbol ok        ok-symbol
 create-symbol if        if-symbol
 create-symbol lambda    lambda-symbol
 create-symbol λ         λ-symbol
+create-symbol begin     begin-symbol
 
 \ }}}
 
@@ -1007,6 +1008,35 @@ parse-idx-stack parse-idx-sp !
     drop compound-proc-type
 ;
 
+: begin? ( obj -- obj bool )
+    begin-symbol tagged-list? ;
+
+: begin-actions ( obj -- actions )
+    cdr ;
+
+: eval-sequence ( explist env -- finalexp env )
+    ( Evaluates all bar the final expressions in
+      an an expression list. The final expression
+      is returned to allow for tail optimization. )
+
+    2swap ( env explist )
+
+    \ Abort on empty list
+    2dup nil objeq? if 2swap exit then
+
+    begin
+        2dup cdr ( env explist nextexplist )
+        2dup nil objeq? false =
+    while
+        -2rot car 2over ( nextexplist env exp env )
+        eval
+        2drop \ discard result
+        2swap ( env nextexplist )
+    repeat
+
+    2drop car 2swap ( finalexp env )
+;
+
 : application? ( obj -- obj bool)
     pair-type istype? ;
 
@@ -1059,19 +1089,7 @@ parse-idx-stack parse-idx-sp !
 
                 extend-env ( body env )
 
-                2swap ( env body )
-
-                begin
-                    2dup cdr 2dup nil objeq? false =
-                while
-                    -2rot car 2over ( nextbody env exp env )
-                    eval
-                    2drop \ discard result
-                    2swap ( env nextbody )
-                repeat
-
-                2drop ( env body )
-                car 2swap ( exp env )
+                eval-sequence
 
                 R> drop ['] eval goto-deferred  \ Tail call optimization
             endof
@@ -1132,6 +1150,10 @@ parse-idx-stack parse-idx-sp !
         exit
     then
 
+    begin? if
+        \ TODO
+    then
+
     application? if
         2over 2over
         operator 2swap eval
@@ -1459,6 +1481,7 @@ include scheme-primitives.4th
         read-console
 
         2dup EOF character-type objeq? if
+            2drop
             bold fg blue ." Moriturus te saluto." reset-term cr
             exit
         then