blob: 7dc9d7e2e9240a4c1553ba2c8acf170baf3ecead (
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
|
require reader.fs
require printer.fs
require env.fs
: args-as-native { argv argc -- entry*argc... }
argc 0 ?do
argv i cells + @ as-native
loop ;
0 MalEnv. constant repl-env
s" +" MalSymbol. :noname args-as-native + MalInt. ; MalNativeFn. repl-env env/set
s" -" MalSymbol. :noname args-as-native - MalInt. ; MalNativeFn. repl-env env/set
s" *" MalSymbol. :noname args-as-native * MalInt. ; MalNativeFn. repl-env env/set
s" /" MalSymbol. :noname args-as-native / MalInt. ; MalNativeFn. repl-env env/set
\ Fully evalutate any Mal object:
def-protocol-method mal-eval ( env ast -- val )
\ Invoke an object, given whole env and unevaluated argument forms:
def-protocol-method invoke ( argv argc mal-fn -- ... )
MalDefault extend mal-eval nip ;; drop
MalKeyword
extend invoke { env list kw -- val }
0 kw env list MalList/start @ cell+ @ mal-eval get
?dup 0= if
\ compute not-found value
list MalList/count @ 1 > if
env list MalList/start @ 2 cells + @ mal-eval
else
mal-nil
endif
endif ;;
drop
MalNativeFn
extend invoke { env list this -- list }
\ Pass args on dictionary stack (!)
\ TODO: consider allocate and free of a real MalList instead
\ Normal list, evaluate and invoke
here { val-start }
list MalList/start @ { expr-start }
list MalList/count @ 1 ?do
env expr-start i cells + @ mal-eval ,
loop
val-start here val-start - cell / this ( argv argc MalNativeFn )
MalNativeFn/xt @ execute
val-start here - allot ;;
drop
SpecialOp
extend invoke ( env list this -- list )
SpecialOp/xt @ execute ;;
drop
: install-special ( symbol xt )
SpecialOp. repl-env env/set ;
: defspecial
parse-allot-name MalSymbol.
['] install-special
:noname
;
defspecial quote ( env list -- form )
nip MalList/start @ cell+ @ ;;
defspecial def! { env list -- }
list MalList/start @ cell+ { arg0 }
arg0 @ ( key )
env arg0 cell+ @ mal-eval dup { val } ( key val )
env env/set
val ;;
defspecial let* { old-env list -- }
old-env MalEnv. { env }
list MalList/start @ cell+ dup { arg0 }
@ to-list
dup MalList/start @ { bindings-start } ( list )
MalList/count @ 0 +do
bindings-start i cells + dup @ swap cell+ @ ( sym expr )
env swap mal-eval
env env/set
2 +loop
env arg0 cell+ @ mal-eval
\ TODO: dec refcount of env
;;
MalSymbol
extend mal-eval { env sym -- val }
0 sym env get
dup 0= if
drop
." Symbol '"
sym as-native safe-type
." ' not found." cr
1 throw
endif ;;
drop
: mal-eval-ast { env list -- list }
here
list MalList/start @ { expr-start }
list MalList/count @ 0 ?do
env expr-start i cells + @ mal-eval ,
loop
here>MalList ;
MalList
extend mal-eval { env list -- val }
env list MalList/start @ @ mal-eval
env list rot invoke ;;
drop
MalVector
extend mal-eval ( env vector -- vector )
MalVector/list @ mal-eval-ast
MalVector new swap over MalVector/list ! ;;
drop
MalMap
extend mal-eval ( env map -- map )
MalMap/list @ mal-eval-ast
MalMap new swap over MalMap/list ! ;;
drop
: read read-str ;
: eval ( env obj ) mal-eval ;
: print
\ ." Type: " dup mal-type @ type-name safe-type cr
pr-str ;
: rep ( str -- val )
read
repl-env swap eval
print ;
create buff 128 allot
: read-lines
begin
." user> "
42042042042
buff 128 stdin read-line throw
while
buff swap
['] rep
execute safe-type
\ catch 0= if safe-type else ." Caught error" endif
cr
42042042042 <> if ." --stack leak--" cr endif
repeat ;
read-lines
cr
bye
|
