From 704194e12c5080f5c6842416a78fe7efa09da068 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 1 Apr 2014 20:06:44 -0500 Subject: [PATCH] PS: add step9_interop: (ps* str) Needs some work, but function. Also need (. x y z) form. --- ps/step9_interop.ps | 253 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 253 insertions(+) create mode 100644 ps/step9_interop.ps diff --git a/ps/step9_interop.ps b/ps/step9_interop.ps new file mode 100644 index 00000000..5ccadf50 --- /dev/null +++ b/ps/step9_interop.ps @@ -0,0 +1,253 @@ +(types.ps) run +(reader.ps) run + +% read +/READ { + /str exch def + str read_str +} def + + +% eval +% is_pair?: ast -> is_pair? -> bool +% return true if non-empty list, otherwise false +/is_pair? { + dup _list? { length 0 gt }{ pop false } ifelse +} def + +% ast -> quasiquote -> new_ast +/quasiquote { 3 dict begin + /ast exch def + ast is_pair? not { %if not is_pair? + /quote ast 2 _list + }{ + /a0 ast 0 get def + a0 /unquote eq { %if a0 unquote symbol + ast 1 get + }{ a0 is_pair? { %elseif a0 is_pair? + /a00 a0 0 get def + a00 /splice-unquote eq { %if splice-unquote + /concat a0 1 get ast _rest quasiquote 3 _list + }{ %else not splice-unquote + /cons a0 quasiquote ast _rest quasiquote 3 _list + } ifelse + }{ % else not a0 is_pair? + /cons a0 quasiquote ast _rest quasiquote 3 _list + } ifelse } ifelse + } ifelse +end } def + +/is_macro_call? { 3 dict begin + /env exch def + /ast exch def + ast _list? { + /a0 ast 0 get def + a0 _symbol? { %if a0 is symbol + env a0 env_find null ne { %if a0 is in env + env a0 env_get _mal_function? { %if user defined function + env a0 env_get /macro? get true eq %if marked as macro + }{ false } ifelse + }{ false } ifelse + }{ false } ifelse + }{ false } ifelse +end } def + +/macroexpand { 3 dict begin + /env exch def + /ast exch def + { + ast env is_macro_call? { + /mac env ast 0 get env_get def + /ast ast _rest mac fload EVAL def + }{ + exit + } ifelse + } loop + ast +end } def + +/eval_ast { 2 dict begin + /env exch def + /ast exch def + %(eval_ast: ) print ast == + ast _symbol? { %if symbol + env ast env_get + }{ ast _list? { %elseif list + [ + ast { + env EVAL + } forall + ] + }{ % else + ast + } ifelse } ifelse +end } def + +/EVAL { 13 dict begin + { %loop (TCO) + + /env exch def + /ast exch def + /loop? false def + + %(EVAL: ) print ast true _pr_str print (\n) print + ast _list? not { %if not a list + ast env eval_ast + }{ %else apply the list + /ast ast env macroexpand def + ast _list? not { %if no longer a list + ast + }{ %else still a list + /a0 ast 0 get def + /def! a0 eq { %if def! + /a1 ast 1 get def + /a2 ast 2 get 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 + /idx exch def + let_env + a1 idx get + a1 idx 1 add get let_env EVAL + env_set + pop % discard the return value + } for + a2 let_env EVAL + }{ /quote a0 eq { %if quote + ast 1 get + }{ /quasiquote a0 eq { %if quasiquote + ast 1 get quasiquote env EVAL + }{ /defmacro! a0 eq { %if defmacro! + /a1 ast 1 get def + /a2 ast 2 get def + a2 env EVAL + dup /macro? true put % set macro flag + env exch a1 exch env_set % def! it + }{ /macroexpand a0 eq { %if defmacro! + ast 1 get env macroexpand + }{ /ps* a0 eq { %if ps* + count /stackcnt exch def + ast 1 get + { + token not { exit } if + exch + } loop + exec + count stackcnt gt { % if new operands on stack + % return an list of new operands + count stackcnt sub array astore + }{ + null % return nil + } ifelse + }{ /do a0 eq { %if do + ast length 2 gt { %if ast has more than 2 elements + ast 1 ast length 2 sub getinterval env eval_ast pop + } if + ast ast length 1 sub get % last ast becomes new ast + env + /loop? true def % loop + }{ /if a0 eq { %if if + /a1 ast 1 get 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 with a3 + ast 3 get env + /loop? true def + }{ % else false branch with no a3 + null + } ifelse + }{ % true branch + ast 2 get env + /loop? true def + } ifelse + }{ /fn* a0 eq { %if fn* + /a1 ast 1 get def + /a2 ast 2 get def + << + /type /_maltype_function % user defined function + /macro? false % macro flag, false by default + /params null % close over parameters + /ast null % close over ast + /env null % close over environment + >> + dup length dict copy % make an actual copy/new instance + dup /params a1 put % insert closed over a1 into position 2 + dup /ast a2 put % insert closed over a2 into position 3 + dup /env env put % insert closed over env into position 4 + }{ + /el ast env eval_ast def + el _first _mal_function? { % if user defined function + el _rest el _first fload % stack: ast new_env + /loop? true def + }{ %else (regular procedure/function) + el _rest el _first exec % apply function to args + } ifelse + } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse + } ifelse + } ifelse + + loop? not { exit } if + } loop % TCO +end } def + + +% print +/PRINT { + true _pr_str +} def + + +% repl +/repl_env 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 + +(read-string) { 0 get read_str } _ref +(eval) { 0 get repl_env EVAL } _ref +/slurp { (r) file dup bytesavailable string readstring pop } def +(slurp) { 0 get slurp } _ref +(pstack) { (vvv\n) print pstack (^^^\n) print } _ref +(p1) { 1 index true _pr_str print (\n) print } _ref + +(\(def! not \(fn* \(a\) \(if a false true\)\)\)) RE pop +(\(def! load-file \(fn* \(f\) \(eval \(read-string \(str "\(do " \(slurp f\) "\)"\)\)\)\)\)) RE pop + +/stdin (%stdin) (r) file def + +userdict /ARGUMENTS known { %if command line arguments + ARGUMENTS length 0 gt { %if more than 0 arguments + ARGUMENTS { + (\(load-file ") exch ("\)) concatenate concatenate RE pop + } forall + quit + } if +} if +{ % loop + (user> ) print flush + + stdin 99 string readline + + not { exit } if % exit if EOF + + %(\ngot line: ) print dup print (\n) print flush + + { %try + REP print (\n) print + } stopped { + (Error: ) print + get_error_data false _pr_str print (\n) print + $error /newerror false put + $error /errorinfo null put + clear + } if +} bind loop + +(\n) print % final newline before exit for cleanliness +quit -- 2.20.1