ps/step6_file.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 /eval_ast { 2 dict begin
  13     /env exch def
  14     /ast exch def
  15     %(eval_ast: ) print ast ==
  16     ast _symbol? { %if symbol
  17         env ast env_get
  18     }{ ast _list? { %elseif list
  19         [
  20             ast {
  21                 env EVAL
  22             } forall
  23         ]
  24     }{ % else
  25         ast
  26     } ifelse } ifelse
  27 end } def
  28
  29 /EVAL { 13 dict begin
  30     { %loop (TCO)
  31
  32     /env exch def
  33     /ast exch def
  34     /loop? false def
  35
  36     %(EVAL: ) print ast ==
  37     ast _list? not { %if not a list
  38         ast env eval_ast
  39     }{ %else apply the list
  40         /a0 ast 0 get def
  41         /def! a0 eq { %if def!
  42             /a1 ast 1 get def
  43             /a2 ast 2 get def
  44             env a1  a2 env EVAL  env_set
  45         }{ /let* a0 eq { %if let*
  46             /a1 ast 1 get def
  47             /a2 ast 2 get def
  48             /let_env env [ ] [ ] env_new def
  49             0 2 a1 length 1 sub { %for each pair
  50                 /idx exch def
  51                 let_env
  52                     a1 idx get
  53                     a1 idx 1 add get let_env EVAL
  54                     env_set
  55             } for
  56             a2 let_env EVAL
  57         }{ /do a0 eq { %if do
  58             ast length 2 ge { %if ast has more than 2 elements
  59                 ast 1 ast length 1 sub getinterval env eval_ast
  60             } if
  61             ast ast length 1 sub get % last ast becomes new ast
  62             env
  63             /loop? true def % loop
  64         }{ /if a0 eq { %if if
  65             /a1 ast 1 get def
  66             /cond a1 env EVAL def
  67             cond null eq cond false eq or { % if cond is nil or false
  68                 ast length 3 gt { %if false branch (a3) provided
  69                     ast 3 get env % new ast is false branch (a3)
  70                     /loop? true def
  71                 }{
  72                     null
  73                 } ifelse
  74             }{
  75                 ast 2 get env % new ast is true branch (a2)
  76                 /loop? true def
  77             } ifelse
  78         }{ /fn* a0 eq { %if fn*
  79             /a1 ast 1 get def
  80             /a2 ast 2 get def
  81             {   /user_defined  % mark this as user defined
  82                 __PARAMS__ __AST__ __ENV__ % closed over variables
  83                 4 dict begin
  84                 /ENV    exch def % closed over above, pos 3
  85                 /AST    exch def % closed over above, pos 2
  86                 /PARAMS exch def % closed over above, pos 1
  87                 pop % remove the type
  88                 /args   exch def
  89                 AST   ENV PARAMS args env_new   EVAL
  90             end }
  91             dup length array copy cvx % make an actual copy/new instance
  92             dup 1 a1 put  % insert closed over a1 into position 1
  93             dup 2 a2 put  % insert closed over a2 into position 2
  94             dup 3 env put % insert closed over env into position 3
  95         }{
  96             /el ast env eval_ast def
  97             el _first 0 get /user_defined eq { %if userdefined function
  98                 /PARAMS el _first 1 get def
  99                 /AST    el _first 2 get def
 100                 /ENV    el _first 3 get def
 101                 AST % new ast is one stored in function
 102                 ENV PARAMS el _rest env_new % new environment
 103                 /loop? true def
 104             }{ %else (regular procedure/function)
 105                 el _rest % args array
 106                 el _first cvx % function
 107                 exec % apply function to args
 108             } ifelse
 109         } ifelse } ifelse } ifelse } ifelse } ifelse
 110     } ifelse
 111
 112     loop? not { exit } if
 113     } loop % TCO
 114 end } def
 115
 116
 117 % print
 118 /PRINT {
 119     true _pr_str
 120 } def
 121
 122
 123 % repl
 124 /repl_env null [ ] [ ] env_new def
 125
 126 /RE { READ repl_env EVAL } def
 127 /REP { READ repl_env EVAL PRINT } def
 128 /_ref { repl_env 3 1 roll env_set pop } def
 129
 130 types_ns { _ref } forall
 131
 132 (read-string) { 0 get read_str } _ref
 133 (eval) { 0 get repl_env EVAL } _ref
 134 /slurp { (r) file dup bytesavailable string readstring pop } def
 135 (slurp) { 0 get slurp } _ref
 136
 137 (\(def! not \(fn* \(a\) \(if a false true\)\)\)) RE pop
 138 (\(def! load-file \(fn* \(f\) \(eval \(read-string \(str "\(do " \(slurp f\) "\)"\)\)\)\)\)) RE pop
 139
 140 /stdin (%stdin) (r) file def
 141
 142 userdict /ARGUMENTS known { %if command line arguments
 143     ARGUMENTS length 0 gt { %if more than 0 arguments
 144         ARGUMENTS {
 145             (\(load-file ") exch ("\)) concatenate concatenate RE pop
 146         } forall
 147         quit
 148     } if
 149 } if
 150 { % loop
 151     (user> ) print flush
 152
 153     stdin 99 string readline
 154
 155     not { exit } if  % exit if EOF
 156
 157     %(\ngot line: ) print dup print (\n) print flush
 158
 159     { %try
 160         REP print (\n) print
 161     } stopped {
 162         (Error: ) print
 163         get_error_data false _pr_str print (\n) print
 164         $error /newerror false put
 165         $error /errorinfo null put
 166         clear
 167     } if
 168 } bind loop
 169
 170 (\n) print  % final newline before exit for cleanliness
 171 quit