mirror of
https://github.com/kanaka/mal.git
synced 2024-09-20 01:57:09 +03:00
301 lines
9.5 KiB
PostScript
301 lines
9.5 KiB
PostScript
/runlibfile where { pop }{ /runlibfile { run } def } ifelse %
|
|
(types.ps) runlibfile
|
|
(reader.ps) runlibfile
|
|
(printer.ps) runlibfile
|
|
(env.ps) runlibfile
|
|
(core.ps) runlibfile
|
|
|
|
% read
|
|
/_readline { print flush (%stdin) (r) file 1024 string readline } def
|
|
|
|
/READ {
|
|
/str exch def
|
|
str read_str
|
|
} def
|
|
|
|
|
|
% eval
|
|
% is_pair?: ast -> is_pair? -> bool
|
|
% return true if non-empty list, otherwise false
|
|
/is_pair? {
|
|
dup _sequential? { _count 0 gt }{ pop false } ifelse
|
|
} def
|
|
|
|
% ast -> quasiquote -> new_ast
|
|
/quasiquote { 3 dict begin
|
|
/ast exch def
|
|
ast is_pair? not { %if not is_pair?
|
|
/quote ast 2 _list
|
|
}{
|
|
/a0 ast 0 _nth def
|
|
a0 /unquote eq { %if a0 unquote symbol
|
|
ast 1 _nth
|
|
}{ a0 is_pair? { %elseif a0 is_pair?
|
|
/a00 a0 0 _nth def
|
|
a00 /splice-unquote eq { %if splice-unquote
|
|
/concat a0 1 _nth ast _rest quasiquote 3 _list
|
|
}{ %else not splice-unquote
|
|
/cons a0 quasiquote ast _rest quasiquote 3 _list
|
|
} ifelse
|
|
}{ % else not a0 is_pair?
|
|
/cons a0 quasiquote ast _rest quasiquote 3 _list
|
|
} ifelse } ifelse
|
|
} ifelse
|
|
end } def
|
|
|
|
/is_macro_call? { 3 dict begin
|
|
/env exch def
|
|
/ast exch def
|
|
ast _list? {
|
|
/a0 ast 0 _nth def
|
|
a0 _symbol? { %if a0 is symbol
|
|
env a0 env_find null ne { %if a0 is in env
|
|
env a0 env_get _mal_function? { %if user defined function
|
|
env a0 env_get /macro? get true eq %if marked as macro
|
|
}{ false } ifelse
|
|
}{ false } ifelse
|
|
}{ false } ifelse
|
|
}{ false } ifelse
|
|
end } def
|
|
|
|
/macroexpand { 3 dict begin
|
|
/env exch def
|
|
/ast exch def
|
|
{
|
|
ast env is_macro_call? {
|
|
/mac env ast 0 _nth env_get def
|
|
/ast ast _rest mac fload EVAL def
|
|
}{
|
|
exit
|
|
} ifelse
|
|
} loop
|
|
ast
|
|
end } def
|
|
|
|
/eval_ast { 2 dict begin
|
|
/env exch def
|
|
/ast exch def
|
|
%(eval_ast: ) print ast ==
|
|
ast _symbol? { %if symbol
|
|
env ast env_get
|
|
}{ ast _sequential? { %elseif list or vector
|
|
[
|
|
ast /data get { %forall items
|
|
env EVAL
|
|
} forall
|
|
] ast _list? { _list_from_array }{ _vector_from_array } ifelse
|
|
}{ ast _hash_map? { %elseif list or vector
|
|
<<
|
|
ast /data get { %forall entries
|
|
env EVAL
|
|
} forall
|
|
>> _hash_map_from_dict
|
|
}{ % else
|
|
ast
|
|
} ifelse } ifelse } ifelse
|
|
end } def
|
|
|
|
/EVAL { 13 dict begin
|
|
{ %loop (TCO)
|
|
|
|
/env exch def
|
|
/ast exch def
|
|
/loop? false def
|
|
|
|
%(EVAL: ) print ast true _pr_str print (\n) print
|
|
ast _list? not { %if not a list
|
|
ast env eval_ast
|
|
}{ %else apply the list
|
|
/ast ast env macroexpand def
|
|
ast _list? not { %if no longer a list
|
|
ast env eval_ast
|
|
}{ %else still a list
|
|
/a0 ast 0 _nth def
|
|
/def! a0 eq { %if def!
|
|
/a1 ast 1 _nth def
|
|
/a2 ast 2 _nth def
|
|
env a1 a2 env EVAL env_set
|
|
}{ /let* a0 eq { %if let*
|
|
/a1 ast 1 _nth def
|
|
/a2 ast 2 _nth def
|
|
/let_env env null null env_new def
|
|
0 2 a1 _count 1 sub { %for each pair
|
|
/idx exch def
|
|
let_env
|
|
a1 idx _nth
|
|
a1 idx 1 add _nth let_env EVAL
|
|
env_set
|
|
pop % discard the return value
|
|
} for
|
|
a2
|
|
let_env
|
|
/loop? true def % loop
|
|
}{ /quote a0 eq { %if quote
|
|
ast 1 _nth
|
|
}{ /quasiquote a0 eq { %if quasiquote
|
|
ast 1 _nth quasiquote
|
|
env
|
|
/loop? true def % loop
|
|
}{ /defmacro! a0 eq { %if defmacro!
|
|
/a1 ast 1 _nth def
|
|
/a2 ast 2 _nth def
|
|
a2 env EVAL
|
|
dup /macro? true put % set macro flag
|
|
env exch a1 exch env_set % def! it
|
|
}{ /macroexpand a0 eq { %if defmacro!
|
|
ast 1 _nth env macroexpand
|
|
}{ /ps* a0 eq { %if ps*
|
|
count /stackcnt exch def
|
|
ast 1 _nth
|
|
{
|
|
token not { exit } if
|
|
exch
|
|
count stackcnt sub 1 roll % send leftover string to bottom
|
|
exec
|
|
count stackcnt sub -1 roll % bring leftover string to top
|
|
} loop
|
|
count stackcnt gt { % if new operands on stack
|
|
% return an list of new operands
|
|
count stackcnt sub array astore
|
|
}{
|
|
null % return nil
|
|
} ifelse
|
|
}{ /do a0 eq { %if do
|
|
ast _count 2 gt { %if ast has more than 2 elements
|
|
ast 1 ast _count 2 sub _slice env eval_ast pop
|
|
} if
|
|
ast ast _count 1 sub _nth % last ast becomes new ast
|
|
env
|
|
/loop? true def % loop
|
|
}{ /try* a0 eq { %if try*
|
|
{ %try
|
|
countdictstack /dictcnt exch def
|
|
count /stackcnt exch def
|
|
ast 1 _nth env EVAL
|
|
} stopped { %catch
|
|
% clean up the dictionary stack
|
|
1 1 countdictstack dictcnt sub { %foreach added dict
|
|
%(popping dict\n) print
|
|
pop end % pop idx and pop dict
|
|
%(new ast: ) print ast true _pr_str print (\n) print
|
|
} for
|
|
% clean up the operand stack
|
|
count 1 exch 1 exch stackcnt sub { %foreach added operand
|
|
%(op stack: ) print pstack
|
|
pop pop % pop idx and operand
|
|
%(popped op stack\n) print pstack
|
|
} for
|
|
% get error data and reset $error dict
|
|
/errdata get_error_data def
|
|
$error /newerror false put
|
|
$error /errorinfo null put
|
|
|
|
ast _count 3 lt { %if no third (catch*) form
|
|
errdata throw
|
|
} if
|
|
ast 2 _nth 0 _nth (catch*) eq not { %if third form not catch*
|
|
(No catch* in throw form) _throw
|
|
} if
|
|
ast 2 _nth 2 _nth
|
|
env
|
|
ast 2 _nth 1 _nth 1 _list
|
|
errdata 1 _list
|
|
env_new
|
|
EVAL
|
|
} if
|
|
}{ /if a0 eq { %if if
|
|
/a1 ast 1 _nth def
|
|
/cond a1 env EVAL def
|
|
cond null eq cond false eq or { % if cond is nil or false
|
|
ast _count 3 gt { %if false branch with a3
|
|
ast 3 _nth env
|
|
/loop? true def
|
|
}{ % else false branch with no a3
|
|
null
|
|
} ifelse
|
|
}{ % true branch
|
|
ast 2 _nth env
|
|
/loop? true def
|
|
} ifelse
|
|
}{ /fn* a0 eq { %if fn*
|
|
/a1 ast 1 _nth def
|
|
/a2 ast 2 _nth def
|
|
a2 env a1 _mal_function
|
|
}{
|
|
/el ast env eval_ast def
|
|
el _rest el _first % stack: ast function
|
|
dup _mal_function? { %if user defined function
|
|
fload % stack: ast new_env
|
|
/loop? true def
|
|
}{ dup _function? { %else if builtin function
|
|
/data get exec
|
|
}{ %else (regular procedure/function)
|
|
(cannot apply native proc!\n) print quit
|
|
} ifelse } ifelse
|
|
} ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse
|
|
} ifelse
|
|
} ifelse
|
|
|
|
loop? not { exit } if
|
|
} loop % TCO
|
|
end } def
|
|
|
|
|
|
% print
|
|
/PRINT {
|
|
true _pr_str
|
|
} def
|
|
|
|
|
|
% repl
|
|
/repl_env null null null env_new def
|
|
|
|
/RE { READ repl_env EVAL } def
|
|
/REP { READ repl_env EVAL PRINT } def
|
|
|
|
% core.ps: defined using postscript
|
|
/_ref { repl_env 3 1 roll env_set pop } def
|
|
core_ns { _function _ref } forall
|
|
(eval) { 0 _nth repl_env EVAL } _function _ref
|
|
(*ARGV*) [ ] _list_from_array _ref
|
|
|
|
% core.mal: defined using the language itself
|
|
(\(def! *host-language* "postscript"\)) RE pop
|
|
(\(def! not \(fn* \(a\) \(if a false true\)\)\)) RE pop
|
|
(\(def! load-file \(fn* \(f\) \(eval \(read-string \(str "\(do " \(slurp f\) "\)"\)\)\)\)\)) RE pop
|
|
(\(defmacro! cond \(fn* \(& xs\) \(if \(> \(count xs\) 0\) \(list 'if \(first xs\) \(if \(> \(count xs\) 1\) \(nth xs 1\) \(throw "odd number of forms to cond"\)\) \(cons 'cond \(rest \(rest xs\)\)\)\)\)\)\)) RE pop
|
|
(\(def! *gensym-counter* \(atom 0\)\)) RE pop
|
|
(\(def! gensym \(fn* [] \(symbol \(str "G__" \(swap! *gensym-counter* \(fn* [x] \(+ 1 x\)\)\)\)\)\)\)) RE pop
|
|
(\(defmacro! or \(fn* \(& xs\) \(if \(empty? xs\) nil \(if \(= 1 \(count xs\)\) \(first xs\) \(let* \(condvar \(gensym\)\) `\(let* \(~condvar ~\(first xs\)\) \(if ~condvar ~condvar \(or ~@\(rest xs\)\)\)\)\)\)\)\)\)) RE pop
|
|
|
|
userdict /ARGUMENTS known { %if command line arguments
|
|
ARGUMENTS length 0 gt { %if more than 0 arguments
|
|
(*ARGV*) ARGUMENTS 1 ARGUMENTS length 1 sub getinterval
|
|
_list_from_array _ref
|
|
ARGUMENTS 0 get
|
|
(\(load-file ") exch ("\)) concatenate concatenate RE pop
|
|
quit
|
|
} if
|
|
} if
|
|
|
|
% repl loop
|
|
(\(println \(str "Mal [" *host-language* "]"\)\)) RE pop
|
|
{ %loop
|
|
(user> ) _readline
|
|
not { exit } if % exit if EOF
|
|
|
|
{ %try
|
|
REP print (\n) print
|
|
} stopped {
|
|
(Error: ) print
|
|
get_error_data false _pr_str print (\n) print
|
|
$error /newerror false put
|
|
$error /errorinfo null put
|
|
clear
|
|
cleardictstack
|
|
} if
|
|
} bind loop
|
|
|
|
(\n) print % final newline before exit for cleanliness
|
|
quit
|