ps/step8_macros.ps

   1 (types.ps) run
   2 (reader.ps) run
   3 (printer.ps) run
   4 (env.ps) run
   5 (core.ps) run
   6
   7 % read
   8 /_readline { print flush (%stdin) (r) file 99 string readline } def
   9
  10 /READ {
  11     /str exch def
  12     str read_str
  13 } def
  14
  15
  16 % eval
  17 % is_pair?: ast -> is_pair? -> bool
  18 % return true if non-empty list, otherwise false
  19 /is_pair? {
  20     dup _list? { _count 0 gt }{ pop false } ifelse
  21 } def
  22
  23 % ast -> quasiquote -> new_ast
  24 /quasiquote { 3 dict begin
  25     /ast exch def
  26     ast is_pair? not { %if not is_pair?
  27         /quote ast 2 _list
  28     }{
  29         /a0 ast 0 _nth def
  30         a0 /unquote eq { %if a0 unquote symbol
  31             ast 1 _nth
  32         }{ a0 is_pair? { %elseif a0 is_pair?
  33             /a00 a0 0 _nth def
  34             a00 /splice-unquote eq { %if splice-unquote
  35                 /concat a0 1 _nth ast _rest quasiquote 3 _list
  36             }{ %else not splice-unquote
  37                 /cons a0 quasiquote ast _rest quasiquote 3 _list
  38             } ifelse
  39         }{ % else not a0 is_pair?
  40             /cons a0 quasiquote ast _rest quasiquote 3 _list
  41         } ifelse } ifelse
  42     } ifelse
  43 end } def
  44
  45 /is_macro_call? { 3 dict begin
  46     /env exch def
  47     /ast exch def
  48     ast _list? {
  49         /a0 ast 0 _nth def
  50         a0 _symbol? { %if a0 is symbol
  51             env a0 env_find null ne { %if a0 is in env
  52                 env a0 env_get _mal_function? { %if user defined function
  53                     env a0 env_get /macro? get true eq %if marked as macro
  54                 }{ false } ifelse
  55             }{ false } ifelse
  56         }{ false } ifelse
  57     }{ false } ifelse
  58 end } def
  59
  60 /macroexpand { 3 dict begin
  61     /env exch def
  62     /ast exch def
  63     {
  64         ast env is_macro_call? {
  65             /mac env   ast 0 _nth   env_get def
  66             /ast ast _rest mac fload EVAL def
  67         }{
  68             exit
  69         } ifelse
  70     } loop
  71     ast
  72 end } def
  73
  74 /eval_ast { 2 dict begin
  75     /env exch def
  76     /ast exch def
  77     %(eval_ast: ) print ast ==
  78     ast _symbol? { %if symbol
  79         env ast env_get
  80     }{ ast _sequential? { %elseif list or vector
  81         [
  82             ast /data get { %forall items
  83                 env EVAL
  84             } forall
  85         ] ast _list? { _list_from_array }{ _vector_from_array } ifelse
  86     }{ ast _hash_map? { %elseif list or vector
  87         <<
  88             ast /data get { %forall entries
  89                 env EVAL
  90             } forall
  91         >> _hash_map_from_dict
  92     }{ % else
  93         ast
  94     } ifelse } ifelse } ifelse
  95 end } def
  96
  97 /EVAL { 13 dict begin
  98     { %loop (TCO)
  99
 100     /env exch def
 101     /ast exch def
 102     /loop? false def
 103
 104     %(EVAL: ) print ast true _pr_str print (\n) print
 105     ast _list? not { %if not a list
 106         ast env eval_ast
 107     }{ %else apply the list
 108       /ast ast env macroexpand def
 109       ast _list? not { %if no longer a list
 110           ast
 111       }{ %else still a list
 112         /a0 ast 0 _nth def
 113         /def! a0 eq { %if def!
 114             /a1 ast 1 _nth def
 115             /a2 ast 2 _nth def
 116             env a1  a2 env EVAL  env_set
 117         }{ /let* a0 eq { %if let*
 118             /a1 ast 1 _nth def
 119             /a2 ast 2 _nth def
 120             /let_env env null null env_new def
 121             0 2 a1 _count 1 sub { %for each pair
 122                 /idx exch def
 123                 let_env
 124                     a1 idx _nth
 125                     a1 idx 1 add _nth let_env EVAL
 126                     env_set
 127                     pop % discard the return value
 128             } for
 129             a2 let_env EVAL
 130         }{ /quote a0 eq { %if quote
 131             ast 1 _nth
 132         }{ /quasiquote a0 eq { %if quasiquote
 133             ast 1 _nth quasiquote   env EVAL
 134         }{ /defmacro! a0 eq { %if defmacro!
 135             /a1 ast 1 _nth def
 136             /a2 ast 2 _nth def
 137             a2 env EVAL
 138             dup /macro? true put % set macro flag
 139             env exch a1 exch env_set % def! it
 140         }{ /macroexpand a0 eq { %if defmacro!
 141             ast 1 _nth env macroexpand
 142         }{ /do a0 eq { %if do
 143             ast _count 2 gt { %if ast has more than 2 elements
 144                 ast 1 ast _count 2 sub _slice env eval_ast pop
 145             } if
 146             ast ast _count 1 sub _nth % last ast becomes new ast
 147             env
 148             /loop? true def % loop
 149         }{ /if a0 eq { %if if
 150             /a1 ast 1 _nth def
 151             /cond a1 env EVAL def
 152             cond null eq cond false eq or { % if cond is nil or false
 153                 ast _count 3 gt { %if false branch with a3
 154                     ast 3 _nth env
 155                     /loop? true def
 156                 }{ % else false branch with no a3
 157                     null
 158                 } ifelse
 159             }{ % true branch
 160                 ast 2 _nth env
 161                 /loop? true def
 162             } ifelse
 163         }{ /fn* a0 eq { %if fn*
 164             /a1 ast 1 _nth def
 165             /a2 ast 2 _nth def
 166             a2 env a1 _mal_function
 167         }{
 168             /el ast env eval_ast def
 169             el _rest el _first % stack: ast function
 170             dup _mal_function? { %if user defined function
 171                 fload % stack: ast new_env
 172                 /loop? true def
 173             }{ dup _function? { %else if builtin function
 174                 /data get exec
 175             }{ %else (regular procedure/function)
 176                 (cannot apply native proc!\n) print quit
 177             } ifelse } ifelse
 178         } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse
 179       } ifelse
 180     } ifelse
 181
 182     loop? not { exit } if
 183     } loop % TCO
 184 end } def
 185
 186
 187 % print
 188 /PRINT {
 189     true _pr_str
 190 } def
 191
 192
 193 % repl
 194 /repl_env null null null env_new def
 195
 196 /RE { READ repl_env EVAL } def
 197 /REP { READ repl_env EVAL PRINT } def
 198 /_ref { _function repl_env 3 1 roll env_set pop } def
 199
 200 core_ns { _ref } forall
 201
 202 (read-string) { 0 _nth read_str } _ref
 203 (eval) { 0 _nth repl_env EVAL } _ref
 204 /slurp { (r) file dup bytesavailable string readstring pop } def
 205 (slurp) { 0 _nth slurp } _ref
 206
 207 (\(def! not \(fn* \(a\) \(if a false true\)\)\)) RE pop
 208 (\(def! load-file \(fn* \(f\) \(eval \(read-string \(str "\(do " \(slurp f\) "\)"\)\)\)\)\)) RE pop
 209
 210 userdict /ARGUMENTS known { %if command line arguments
 211     ARGUMENTS length 0 gt { %if more than 0 arguments
 212         ARGUMENTS {
 213             (\(load-file ") exch ("\)) concatenate concatenate RE pop
 214         } forall
 215         quit
 216     } if
 217 } if
 218 { % loop
 219     (user> ) _readline
 220     not { exit } if  % exit if EOF
 221
 222     { %try
 223         REP print (\n) print
 224     } stopped {
 225         (Error: ) print
 226         get_error_data false _pr_str print (\n) print
 227         $error /newerror false put
 228         $error /errorinfo null put
 229         clear
 230         cleardictstack
 231     } if
 232 } bind loop
 233
 234 (\n) print  % final newline before exit for cleanliness
 235 quit