ps/step7_quote.ps

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