ps/step9_interop.ps

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