diff options
| -rw-r--r-- | ps/Makefile | 15 | ||||
| -rw-r--r-- | ps/step2_eval.ps | 10 | ||||
| -rw-r--r-- | ps/step3_env.ps | 5 | ||||
| -rw-r--r-- | ps/step4_if_fn_do.ps | 49 | ||||
| -rw-r--r-- | ps/step5_tco.ps | 53 | ||||
| -rw-r--r-- | ps/step6_file.ps | 53 | ||||
| -rw-r--r-- | ps/step7_quote.ps | 53 | ||||
| -rw-r--r-- | ps/step8_macros.ps | 239 | ||||
| -rw-r--r-- | ps/types.ps | 35 |
9 files changed, 384 insertions, 128 deletions
diff --git a/ps/Makefile b/ps/Makefile new file mode 100644 index 0000000..231e8aa --- /dev/null +++ b/ps/Makefile @@ -0,0 +1,15 @@ + +TESTS = + +SOURCES = types.ps reader.ps step8_macros.ps + +.PHONY: stats tests $(TESTS) + +stats: $(SOURCES) + @wc $^ + +tests: $(TESTS) + +$(TESTS): + @echo "Running $@"; \ + gs -q -dNODISPLAY -- $@ || exit 1; \ diff --git a/ps/step2_eval.ps b/ps/step2_eval.ps index 04e6a50..aa34bf5 100644 --- a/ps/step2_eval.ps +++ b/ps/step2_eval.ps @@ -13,14 +13,14 @@ /env exch def /ast exch def %(eval_ast: ) print ast == - /nametype ast type eq { %if symbol + ast _symbol? { %if symbol env ast known { env ast get }{ (') ast pr_str (' not found) concatenate concatenate throw } ifelse - }{ /arraytype ast type eq { %elseif list + }{ ast _list? { %elseif list [ ast { env EVAL @@ -35,13 +35,11 @@ end } def /env exch def /ast exch def %(EVAL: ) print ast == - /arraytype ast type ne { %if not a list + ast _list? not { %if not a list ast env eval_ast }{ %else apply the list /el ast env eval_ast def - el _rest % args array - el _first % function - exec % apply function to args + el _rest el _first exec % apply function to args } ifelse end } def diff --git a/ps/step3_env.ps b/ps/step3_env.ps index 5feae46..e906386 100644 --- a/ps/step3_env.ps +++ b/ps/step3_env.ps @@ -48,13 +48,12 @@ end } def a1 idx get a1 idx 1 add get let_env EVAL env_set + pop % discard the return value } for a2 let_env EVAL }{ /el ast env eval_ast def - el _rest % args array - el _first cvx % function - exec % apply function to args + el _rest el _first exec % apply function to args } ifelse } ifelse } ifelse end } def diff --git a/ps/step4_if_fn_do.ps b/ps/step4_if_fn_do.ps index d92d75a..56152c6 100644 --- a/ps/step4_if_fn_do.ps +++ b/ps/step4_if_fn_do.ps @@ -29,7 +29,8 @@ 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 @@ -48,6 +49,7 @@ end } def a1 idx get a1 idx 1 add get let_env EVAL env_set + pop % discard the return value } for a2 let_env EVAL }{ /do a0 eq { %if do @@ -57,36 +59,37 @@ end } def /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 (a3) provided - ast 3 get env EVAL % EVAL false branch (a3) - }{ + ast length 3 gt { %if false branch with a3 + ast 3 get env + EVAL + }{ % else false branch with no a3 null } ifelse - }{ - ast 2 get env EVAL % EVAL true branch (a2) + }{ % true branch + ast 2 get 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 + << + /type /_maltype_function % user defined function + /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 _rest % args array - el _first cvx % function - exec % apply function to args + el _first _mal_function? { % if user defined function + el _rest el _first fload % stack: ast new_env + EVAL + }{ %else (regular procedure/function) + el _rest el _first exec % apply function to args + } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse end } def diff --git a/ps/step5_tco.ps b/ps/step5_tco.ps index 0984a8f..52e5d02 100644 --- a/ps/step5_tco.ps +++ b/ps/step5_tco.ps @@ -33,7 +33,7 @@ end } def /ast exch def /loop? false 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 @@ -52,11 +52,12 @@ end } def a1 idx get a1 idx 1 add get let_env EVAL env_set + pop % discard the return value } for a2 let_env EVAL }{ /do a0 eq { %if do - ast length 2 ge { %if ast has more than 2 elements - ast 1 ast length 1 sub getinterval env eval_ast + 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 @@ -65,46 +66,36 @@ end } def /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 (a3) provided - ast 3 get env % new ast is false branch (a3) + ast length 3 gt { %if false branch with a3 + ast 3 get env /loop? true def - }{ + }{ % else false branch with no a3 null } ifelse - }{ - ast 2 get env % new ast is true branch (a2) + }{ % 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 - { /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 + << + /type /_maltype_function % user defined function + /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 0 get /user_defined eq { %if userdefined function - /PARAMS el _first 1 get def - /AST el _first 2 get def - /ENV el _first 3 get def - AST % new ast is one stored in function - ENV PARAMS el _rest env_new % new environment + 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 % args array - el _first cvx % function - exec % apply function to args + el _rest el _first exec % apply function to args } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse diff --git a/ps/step6_file.ps b/ps/step6_file.ps index 70c1357..2172942 100644 --- a/ps/step6_file.ps +++ b/ps/step6_file.ps @@ -33,7 +33,7 @@ end } def /ast exch def /loop? false 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 @@ -52,11 +52,12 @@ end } def a1 idx get a1 idx 1 add get let_env EVAL env_set + pop % discard the return value } for a2 let_env EVAL }{ /do a0 eq { %if do - ast length 2 ge { %if ast has more than 2 elements - ast 1 ast length 1 sub getinterval env eval_ast + 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 @@ -65,46 +66,36 @@ end } def /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 (a3) provided - ast 3 get env % new ast is false branch (a3) + ast length 3 gt { %if false branch with a3 + ast 3 get env /loop? true def - }{ + }{ % else false branch with no a3 null } ifelse - }{ - ast 2 get env % new ast is true branch (a2) + }{ % 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 - { /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 + << + /type /_maltype_function % user defined function + /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 0 get /user_defined eq { %if userdefined function - /PARAMS el _first 1 get def - /AST el _first 2 get def - /ENV el _first 3 get def - AST % new ast is one stored in function - ENV PARAMS el _rest env_new % new environment + 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 % args array - el _first cvx % function - exec % apply function to args + el _rest el _first exec % apply function to args } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse diff --git a/ps/step7_quote.ps b/ps/step7_quote.ps index 91cd803..17d7e00 100644 --- a/ps/step7_quote.ps +++ b/ps/step7_quote.ps @@ -61,7 +61,7 @@ end } def /ast exch def /loop? false 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 @@ -80,6 +80,7 @@ end } def 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 @@ -87,8 +88,8 @@ end } def }{ /quasiquote a0 eq { %if quasiquote ast 1 get quasiquote env EVAL }{ /do a0 eq { %if do - ast length 2 ge { %if ast has more than 2 elements - ast 1 ast length 1 sub getinterval env eval_ast + 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 @@ -97,46 +98,36 @@ end } def /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 (a3) provided - ast 3 get env % new ast is false branch (a3) + ast length 3 gt { %if false branch with a3 + ast 3 get env /loop? true def - }{ + }{ % else false branch with no a3 null } ifelse - }{ - ast 2 get env % new ast is true branch (a2) + }{ % 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 - { /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 + << + /type /_maltype_function % user defined function + /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 0 get /user_defined eq { %if userdefined function - /PARAMS el _first 1 get def - /AST el _first 2 get def - /ENV el _first 3 get def - AST % new ast is one stored in function - ENV PARAMS el _rest env_new % new environment + 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 % args array - el _first cvx % function - exec % apply function to args + el _rest el _first exec % apply function to args } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse diff --git a/ps/step8_macros.ps b/ps/step8_macros.ps new file mode 100644 index 0000000..1af1829 --- /dev/null +++ b/ps/step8_macros.ps @@ -0,0 +1,239 @@ +(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 + }{ /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 + + 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 diff --git a/ps/types.ps b/ps/types.ps index a830108..1eb2cf5 100644 --- a/ps/types.ps +++ b/ps/types.ps @@ -35,9 +35,16 @@ dup /func? exch xcheck def % executable function /obj exch cvlit def - /arraytype obj type eq { % if list + obj _mal_function? { % if user defined function + (<\(fn* ) + obj /params get print_readably _pr_str + ( ) + obj /ast get print_readably _pr_str + (\)>) + concatenate concatenate concatenate concatenate + }{ /arraytype obj type eq { % if list or code block % accumulate an array of strings - func? { (<fn* { ) }{ (\() } ifelse + func? { (<builtin_fn* { ) }{ (\() } ifelse obj ( ) print_readably _pr_str_args concatenate func? { ( } >) }{ (\)) } ifelse @@ -61,7 +68,7 @@ obj dup length string cvs }{ (<unknown>) - } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse + } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse end } def % array delim print_readably -> _pr_str_args -> new_string @@ -120,6 +127,25 @@ end } def type /nametype eq } def +% +% Functions +% +/_mal_function? { + dup type /dicttype eq { + /type get /_maltype_function eq + }{ + pop false + } ifelse +} def + +% args mal_function -> fload -> ast new_env +% fload: sets up arguments on the stack for an EVAL call +/fload { + dup /ast get 3 1 roll % stack: ast args mal_function + dup /env get 3 1 roll % stack: ast env args mal_function + /params get exch % stack: ast env params args + env_new % stack: ast new_env +} def % % Errors/Exceptions @@ -274,4 +300,7 @@ end } def (concat) { dup 0 get exch 1 get _concat } (empty?) { 0 get length 0 eq } (count) { 0 get length } + (nth) { dup 0 get exch 1 get _nth } + (first) { 0 get _first } + (rest) { 0 get _rest } >> def |