blob: 1eff14f39d90f441b401a32ffa080f486576ce9b (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
(types.ps) run
(reader.ps) run
(printer.ps) run
(env.ps) run
(core.ps) run
% read
/_readline { print flush (%stdin) (r) file 99 string readline } def
/READ {
/str exch def
str read_str
} def
% eval
/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
/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 EVAL
}{ /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
}{ /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
<<
/_maltype_ /function % user defined function
/params null % close over parameters
/ast null % close over ast
/env null % close over environment
/data { __self__ fload EVAL }
>>
dup length dict copy % make an actual copy/new instance
dup /params a1 put % insert closed over a1 into position 2
dup /ast a2 put % insert closed over a2 into position 3
dup /env env put % insert closed over env into position 4
dup dup /data get exch 0 exch put % insert self reference
}{
/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
}{ %else (regular procedure/function)
exec % apply function to args
} 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
/_ref { repl_env 3 1 roll env_set pop } def
core_ns { _ref } forall
(read-string) { 0 _nth read_str } _ref
(eval) { 0 _nth repl_env EVAL } _ref
/slurp { (r) file dup bytesavailable string readstring pop } def
(slurp) { 0 _nth slurp } _ref
(\(def! not \(fn* \(a\) \(if a false true\)\)\)) RE pop
(\(def! load-file \(fn* \(f\) \(eval \(read-string \(str "\(do " \(slurp f\) "\)"\)\)\)\)\)) RE pop
userdict /ARGUMENTS known { %if command line arguments
ARGUMENTS length 0 gt { %if more than 0 arguments
ARGUMENTS {
(\(load-file ") exch ("\)) concatenate concatenate RE pop
} forall
quit
} if
} if
{ % 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
|
