ps/step4_if_fn_do.ps

   1 (types.ps) run
   2 (reader.ps) run
   3
   4 % read
   5 /_readline { print flush (%stdin) (r) file 99 string readline } def
   6
   7 /READ {
   8     /str exch def
   9     str read_str
  10 } def
  11
  12
  13 % eval
  14 /eval_ast { 2 dict begin
  15     /env exch def
  16     /ast exch def
  17     %(eval_ast: ) print ast ==
  18     ast _symbol? { %if symbol
  19         env ast env_get
  20     }{ ast _list? { %elseif list
  21         [
  22             ast {
  23                 env EVAL
  24             } forall
  25         ]
  26     }{ % else
  27         ast
  28     } ifelse } ifelse
  29 end } def
  30
  31 /EVAL { 9 dict begin
  32     /env exch def
  33     /ast exch def
  34
  35     %(EVAL: ) print ast true _pr_str print (\n) print
  36     ast _list? not { %if not a list
  37         ast env eval_ast
  38     }{ %else apply the list
  39         /a0 ast 0 get def
  40         /def! a0 eq { %if def!
  41             /a1 ast 1 get def
  42             /a2 ast 2 get def
  43             env a1  a2 env EVAL  env_set
  44         }{ /let* a0 eq { %if let*
  45             /a1 ast 1 get def
  46             /a2 ast 2 get def
  47             /let_env env [ ] [ ] env_new def
  48             0 2 a1 length 1 sub { %for each pair
  49                 /idx exch def
  50                 let_env
  51                     a1 idx get
  52                     a1 idx 1 add get let_env EVAL
  53                     env_set
  54                     pop % discard the return value
  55             } for
  56             a2 let_env EVAL
  57         }{ /do a0 eq { %if do
  58             /el ast _rest env eval_ast def
  59             el el length 1 sub get % return last value
  60         }{ /if a0 eq { %if if
  61             /a1 ast 1 get def
  62             /cond a1 env EVAL def
  63             cond null eq cond false eq or { % if cond is nil or false
  64                 ast length 3 gt { %if false branch with a3
  65                     ast 3 get env
  66                     EVAL
  67                 }{ % else false branch with no a3
  68                     null
  69                 } ifelse
  70             }{ % true branch
  71                 ast 2 get env
  72                 EVAL
  73             } ifelse
  74         }{ /fn* a0 eq { %if fn*
  75             /a1 ast 1 get def
  76             /a2 ast 2 get def
  77             <<
  78                 /type /_maltype_function % user defined function
  79                 /params null % close over parameters
  80                 /ast null    % close over ast
  81                 /env null    % close over environment
  82                 /data { __self__ fload EVAL }
  83             >>
  84             dup length dict copy % make an actual copy/new instance
  85             dup /params a1 put  % insert closed over a1 into position 2
  86             dup /ast a2 put  % insert closed over a2 into position 3
  87             dup /env env put % insert closed over env into position 4
  88             dup   dup /data get   exch 0 exch put % insert self reference
  89         }{
  90             /el ast env eval_ast def
  91             el _rest el _first % stack: ast function
  92             dup _mal_function? { % if user defined function
  93                 fload % stack: ast new_env
  94                 EVAL
  95             }{ %else (regular procedure/function)
  96                 exec % apply function to args
  97             } ifelse
  98         } ifelse } ifelse } ifelse } ifelse } ifelse
  99     } ifelse
 100 end } def
 101
 102
 103 % print
 104 /PRINT {
 105     true _pr_str
 106 } def
 107
 108
 109 % repl
 110 /repl_env null [ ] [ ] env_new def
 111
 112 /RE { READ repl_env EVAL } def
 113 /REP { READ repl_env EVAL PRINT } def
 114 /_ref { repl_env 3 1 roll env_set pop } def
 115
 116 types_ns { _ref } forall
 117
 118 (\(def! not \(fn* \(a\) \(if a false true\)\)\)) RE pop
 119
 120 { % loop
 121     (user> ) _readline
 122     not { exit } if  % exit if EOF
 123
 124     { %try
 125         REP print (\n) print
 126     } stopped {
 127         (Error: ) print
 128         get_error_data false _pr_str print (\n) print
 129         $error /newerror false put
 130         $error /errorinfo null put
 131         clear
 132         cleardictstack
 133     } if
 134 } bind loop
 135
 136 (\n) print  % final newline before exit for cleanliness
 137 quit