ps/step7_quote.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 /eval_ast { 2 dict begin
  46     /env exch def
  47     /ast exch def
  48     %(eval_ast: ) print ast ==
  49     ast _symbol? { %if symbol
  50         env ast env_get
  51     }{ ast _sequential? { %elseif list or vector
  52         [
  53             ast /data get { %forall items
  54                 env EVAL
  55             } forall
  56         ] ast _list? { _list_from_array }{ _vector_from_array } ifelse
  57     }{ ast _hash_map? { %elseif list or vector
  58         <<
  59             ast /data get { %forall entries
  60                 env EVAL
  61             } forall
  62         >> _hash_map_from_dict
  63     }{ % else
  64         ast
  65     } ifelse } ifelse } ifelse
  66 end } def
  67
  68 /EVAL { 13 dict begin
  69     { %loop (TCO)
  70
  71     /env exch def
  72     /ast exch def
  73     /loop? false def
  74
  75     %(EVAL: ) print ast true _pr_str print (\n) print
  76     ast _list? not { %if not a list
  77         ast env eval_ast
  78     }{ %else apply the list
  79         /a0 ast 0 _nth def
  80         /def! a0 eq { %if def!
  81             /a1 ast 1 _nth def
  82             /a2 ast 2 _nth def
  83             env a1  a2 env EVAL  env_set
  84         }{ /let* a0 eq { %if let*
  85             /a1 ast 1 _nth def
  86             /a2 ast 2 _nth def
  87             /let_env env null null env_new def
  88             0 2 a1 _count 1 sub { %for each pair
  89                 /idx exch def
  90                 let_env
  91                     a1 idx _nth
  92                     a1 idx 1 add _nth let_env EVAL
  93                     env_set
  94                     pop % discard the return value
  95             } for
  96             a2 let_env EVAL
  97         }{ /quote a0 eq { %if quote
  98             ast 1 _nth
  99         }{ /quasiquote a0 eq { %if quasiquote
 100             ast 1 _nth quasiquote   env EVAL
 101         }{ /do a0 eq { %if do
 102             ast _count 2 gt { %if ast has more than 2 elements
 103                 ast 1 ast _count 2 sub _slice env eval_ast pop
 104             } if
 105             ast ast _count 1 sub _nth % last ast becomes new ast
 106             env
 107             /loop? true def % loop
 108         }{ /if a0 eq { %if if
 109             /a1 ast 1 _nth def
 110             /cond a1 env EVAL def
 111             cond null eq cond false eq or { % if cond is nil or false
 112                 ast _count 3 gt { %if false branch with a3
 113                     ast 3 _nth env
 114                     /loop? true def
 115                 }{ % else false branch with no a3
 116                     null
 117                 } ifelse
 118             }{ % true branch
 119                 ast 2 _nth env
 120                 /loop? true def
 121             } ifelse
 122         }{ /fn* a0 eq { %if fn*
 123             /a1 ast 1 _nth def
 124             /a2 ast 2 _nth def
 125             a2 env a1 _mal_function
 126         }{
 127             /el ast env eval_ast def
 128             el _rest el _first % stack: ast function
 129             dup _mal_function? { %if user defined function
 130                 fload % stack: ast new_env
 131                 /loop? true def
 132             }{ dup _function? { %else if builtin function
 133                 /data get exec
 134             }{ %else (regular procedure/function)
 135                 (cannot apply native proc!\n) print quit
 136             } ifelse } ifelse
 137         } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse
 138     } ifelse
 139
 140     loop? not { exit } if
 141     } loop % TCO
 142 end } def
 143
 144
 145 % print
 146 /PRINT {
 147     true _pr_str
 148 } def
 149
 150
 151 % repl
 152 /repl_env null null null env_new def
 153
 154 /RE { READ repl_env EVAL } def
 155 /REP { READ repl_env EVAL PRINT } def
 156
 157 % core.ps: defined using postscript
 158 /_ref { _function repl_env 3 1 roll env_set pop } def
 159 core_ns { _ref } forall
 160 (eval) { 0 _nth repl_env EVAL } _ref
 161
 162 % core.mal: defined using the language itself
 163 (\(def! not \(fn* \(a\) \(if a false true\)\)\)) RE pop
 164 (\(def! load-file \(fn* \(f\) \(eval \(read-string \(str "\(do " \(slurp f\) "\)"\)\)\)\)\)) RE pop
 165
 166 userdict /ARGUMENTS known { %if command line arguments
 167     ARGUMENTS length 0 gt { %if more than 0 arguments
 168         ARGUMENTS {
 169             (\(load-file ") exch ("\)) concatenate concatenate RE pop
 170         } forall
 171         quit
 172     } if
 173 } if
 174 { % loop
 175     (user> ) _readline
 176     not { exit } if  % exit if EOF
 177
 178     { %try
 179         REP print (\n) print
 180     } stopped {
 181         (Error: ) print
 182         get_error_data false _pr_str print (\n) print
 183         $error /newerror false put
 184         $error /errorinfo null put
 185         clear
 186         cleardictstack
 187     } if
 188 } bind loop
 189
 190 (\n) print  % final newline before exit for cleanliness
 191 quit