bbc-basic: Start of step 9: add 'try*' form and 'throw'.

[jackhill/mal.git] / ps / step4_if_fn_do.ps

diff --git a/ps/step4_if_fn_do.ps b/ps/step4_if_fn_do.ps
index d92d75a..87b43cf 100644 (file)
--- a/ps/step4_if_fn_do.ps
+++ b/ps/step4_if_fn_do.ps
@@ -1,7 +1,13 @@
-(types.ps) run
-(reader.ps) run
+/runlibfile where { pop }{ /runlibfile { run } def } ifelse % 
+(types.ps) runlibfile
+(reader.ps) runlibfile
+(printer.ps) runlibfile
+(env.ps) runlibfile
+(core.ps) runlibfile
 
 % read
+/_readline { print flush (%stdin) (r) file 1024 string readline } def
+
 /READ {
     /str exch def
     str read_str
@@ -15,79 +21,84 @@
     %(eval_ast: ) print ast ==
     ast _symbol? { %if symbol
         env ast env_get
-    }{ ast _list? { %elseif list
+    }{ ast _sequential? { %elseif list or vector
         [
-            ast {
+            ast /data get { %forall items
+                env EVAL
+            } forall
+        ] ast _list? { _list_from_array }{ _vector_from_array } ifelse
+    }{ ast _hash_map? { %elseif list or vector
+        <<
+            ast /data get { %forall entries
                 env EVAL
             } forall
-        ]
+        >> _hash_map_from_dict
     }{ % else
         ast
-    } ifelse } ifelse
+    } ifelse } ifelse } ifelse
 end } def
 
 /EVAL { 9 dict begin
     /env exch def
     /ast exch def
-    %(EVAL: ) print ast ==
+
+    %(EVAL: ) print ast true _pr_str print (\n) print
     ast _list? not { %if not a list
         ast env eval_ast
     }{ %else apply the list
-        /a0 ast 0 get def
-        /def! a0 eq { %if def!
-            /a1 ast 1 get def
-            /a2 ast 2 get def
+        /a0 ast 0 _nth def
+        a0 _nil? { %if ()
+            ast
+        }{ /def! a0 eq { %if def!
+            /a1 ast 1 _nth def
+            /a2 ast 2 _nth def
             env a1  a2 env EVAL  env_set
         }{ /let* a0 eq { %if let*
-            /a1 ast 1 get def
-            /a2 ast 2 get def
-            /let_env env [ ] [ ] env_new def
-            0 2 a1 length 1 sub { %for each pair
+            /a1 ast 1 _nth def
+            /a2 ast 2 _nth def
+            /let_env env null null env_new def
+            0 2 a1 _count 1 sub { %for each pair
                 /idx exch def
                 let_env
-                    a1 idx get
-                    a1 idx 1 add get let_env EVAL
+                    a1 idx _nth
+                    a1 idx 1 add _nth let_env EVAL
                     env_set
+                    pop % discard the return value
             } for
             a2 let_env EVAL
         }{ /do a0 eq { %if do
             /el ast _rest env eval_ast def
-            el el length 1 sub get % return last value
+            el el _count 1 sub _nth % return last value
         }{ /if a0 eq { %if if
-            /a1 ast 1 get def
+            /a1 ast 1 _nth def
             /cond a1 env EVAL def
             cond null eq cond false eq or { % if cond is nil or false
-                ast length 3 gt { %if false branch (a3) provided
-                    ast 3 get env EVAL % EVAL false branch (a3)
-                }{
+                ast _count 3 gt { %if false branch with a3
+                    ast 3 _nth env
+                    EVAL
+                }{ % else false branch with no a3
                     null
                 } ifelse
-            }{
-                ast 2 get env EVAL % EVAL true branch (a2)
+            }{ % true branch
+                ast 2 _nth env
+                EVAL
             } ifelse
         }{ /fn* a0 eq { %if fn*
-            /a1 ast 1 get def
-            /a2 ast 2 get def
-            {   /user_defined  % mark this as user defined
-                __PARAMS__ __AST__ __ENV__ % closed over variables
-                4 dict begin
-                /ENV    exch def % closed over above, pos 3
-                /AST    exch def % closed over above, pos 2
-                /PARAMS exch def % closed over above, pos 1
-                pop % remove the type
-                /args   exch def
-                AST   ENV PARAMS args env_new   EVAL
-            end }
-            dup length array copy cvx % make an actual copy/new instance
-            dup 1 a1 put  % insert closed over a1 into position 1
-            dup 2 a2 put  % insert closed over a2 into position 2
-            dup 3 env put % insert closed over env into position 3
+            /a1 ast 1 _nth def
+            /a2 ast 2 _nth def
+            a2 env a1 _mal_function
         }{
             /el ast env eval_ast def
-            el _rest % args array
-            el _first cvx % function
-            exec % apply function to args
-        } ifelse } ifelse } ifelse } ifelse } ifelse
+            el _rest el _first % stack: ast function
+            dup _mal_function? { %if user defined function
+                fload % stack: ast new_env
+                EVAL
+            }{ dup _function? { %else if builtin function
+                /data get exec
+            }{ %else (regular procedure/function)
+                (cannot apply native proc!\n) print quit
+            } ifelse } ifelse
+        } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse
     } ifelse
 end } def
 
@@ -99,27 +110,23 @@ end } def
 
 
 % repl
-/repl_env null [ ] [ ] env_new def
+/repl_env null null null env_new def
 
 /RE { READ repl_env EVAL } def
 /REP { READ repl_env EVAL PRINT } def
-/_ref { repl_env 3 1 roll env_set pop } def
 
-types_ns { _ref } forall
+% core.ps: defined using postscript
+/_ref { repl_env 3 1 roll env_set pop } def
+core_ns { _function _ref } forall
 
+% core.mal: defined using the language itself
 (\(def! not \(fn* \(a\) \(if a false true\)\)\)) RE pop
 
-/stdin (%stdin) (r) file def 
-
-{ % loop
-    (user> ) print flush
-
-    stdin 99 string readline
-
+% repl loop
+{ %loop
+    (user> ) _readline
     not { exit } if  % exit if EOF
 
-    %(\ngot line: ) print dup print (\n) print flush
-
     { %try
         REP print (\n) print
     } stopped {
@@ -128,6 +135,7 @@ types_ns { _ref } forall
         $error /newerror false put
         $error /errorinfo null put
         clear
+        cleardictstack
     } if
 } bind loop