Implemented begin. Added none object for empty returns.

[scheme.forth.jl.git] / scheme.4th

diff --git a/scheme.4th b/scheme.4th
index b2efe17..136c8a8 100644 (file)
--- a/scheme.4th
+++ b/scheme.4th
@@ -28,6 +28,7 @@ make-type boolean-type
 make-type character-type
 make-type string-type
 make-type nil-type
+make-type none-type
 make-type pair-type
 make-type symbol-type
 make-type primitive-proc-type
@@ -112,6 +113,9 @@ variable nextfree
 : nil 0 nil-type ;
 : nil? nil-type istype? ;
 
+: none 0 none-type ;
+: none? none-type istype? ;
+
 : objvar create nil swap , , ;
 
 : value@ ( objvar -- val ) @ ;
@@ -271,6 +275,7 @@ create-symbol ok        ok-symbol
 create-symbol if        if-symbol
 create-symbol lambda    lambda-symbol
 create-symbol λ         λ-symbol
+create-symbol begin     begin-symbol
 
 \ }}}
 
@@ -885,6 +890,7 @@ parse-idx-stack parse-idx-sp !
     character-type istype? if true exit then
     string-type istype? if true exit then
     nil-type istype? if true exit then
+    none-type istype? if true exit then
 
     false
 ;
@@ -1007,6 +1013,38 @@ 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
+        2drop none
+        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 +1097,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 +1158,12 @@ parse-idx-stack parse-idx-sp !
         exit
     then
 
+    begin? if
+        begin-actions 2swap
+        eval-sequence
+        ['] eval goto-deferred
+    then
+
     application? if
         2over 2over
         operator 2swap eval
@@ -1216,6 +1248,9 @@ parse-idx-stack parse-idx-sp !
 : printcomp ( primobj -- )
     2drop ." <compound procedure>" ;
 
+: printnone ( noneobj -- )
+    2drop ." Unspecified return value" ;
+
 :noname ( obj -- )
     fixnum-type istype? if printfixnum exit then
     realnum-type istype? if printrealnum exit then
@@ -1227,6 +1262,7 @@ parse-idx-stack parse-idx-sp !
     pair-type istype? if ." (" printpair ." )" exit then
     primitive-proc-type istype? if printprim exit then
     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
@@ -1412,24 +1448,36 @@ include scheme-primitives.4th
     swap -
 ;
 
-: load ( addr n -- )
+: load ( addr n -- finalResult )
     open-input-file
 
     empty-parse-str
 
+    ok-symbol ( port res )
+
     begin
-        2dup read-port
+        2over read-port ( port res obj )
 
         2dup EOF character-type objeq? if
-            2drop close-port
+            2drop 2swap close-port
             exit
         then
 
-        global-env obj@ eval
-        2drop
+        2swap 2drop ( port obj )
+
+        global-env obj@ eval ( port res )
     again
 ;
 
+:noname ( args -- finalResult )
+    2dup 1 ensure-arg-count
+    car string-type ensure-arg-type
+
+    drop pair-type
+    pad charlist>cstr
+    pad swap load
+; make-primitive load
+
 \ }}}
 
 \ ---- REPL ----
@@ -1447,6 +1495,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
@@ -1457,9 +1506,6 @@ include scheme-primitives.4th
     again
 ;
 
-: test s" fact.scm" ;
-test load
-
 forth definitions
 
 \ vim:fdm=marker