Commit | Line | Data |
---|---|---|
df784d97 BH |
1 | REM Step 9 of mal in BBC BASIC |
2 | ||
3 | LIBRARY "types" | |
4 | LIBRARY "reader" | |
5 | LIBRARY "printer" | |
6 | LIBRARY "env" | |
7 | LIBRARY "core" | |
8 | ||
9 | PROCtypes_init | |
10 | ||
11 | repl_env% = FNalloc_environment(FNnil) | |
12 | PROCcore_ns : REM This sets the data pointer | |
13 | REPEAT | |
14 | READ sym$, i% | |
15 | IF sym$ <> "" THEN | |
16 | PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) | |
17 | ENDIF | |
18 | UNTIL sym$ = "" | |
19 | ||
20 | REM Initial forms to evaluate | |
21 | RESTORE +0 | |
22 | DATA (def! not (fn* (a) (if a false true))) | |
e6d41de4 | 23 | DATA (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) |
df784d97 | 24 | DATA (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))))))) |
df784d97 BH |
25 | DATA "" |
26 | REPEAT | |
27 | READ form$ | |
28 | IF form$ <> "" THEN val$ = FNrep(form$) | |
29 | UNTIL form$ = "" | |
30 | ||
cbc6f3fb | 31 | argv% = FNget_argv |
0cf722a5 | 32 | |
5881fe23 BH |
33 | IF FNis_empty(argv%) THEN |
34 | PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty) | |
35 | ELSE | |
36 | PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%)) | |
0f97a00d | 37 | val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")") |
0cf722a5 BH |
38 | END |
39 | ENDIF | |
40 | ||
d4b2e8b2 | 41 | sav% = FNgc_save |
df784d97 | 42 | REPEAT |
df784d97 | 43 | REM Catch all errors apart from "Escape". |
d4b2e8b2 BH |
44 | ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ |
45 | PROCgc_restore(sav%) | |
1610afd2 | 46 | sav% = FNgc_save |
df784d97 BH |
47 | PRINT "user> "; |
48 | LINE INPUT "" line$ | |
49 | PRINT FNrep(line$) | |
df784d97 BH |
50 | UNTIL FALSE |
51 | ||
52 | END | |
53 | ||
54 | DEF FNREAD(a$) | |
0f97a00d | 55 | =FNread_str(FNalloc_string(a$)) |
df784d97 BH |
56 | |
57 | DEF FNis_pair(val%) | |
9152704f | 58 | =FNis_seq(val%) AND NOT FNis_empty(val%) |
df784d97 BH |
59 | |
60 | DEF FNquasiquote(ast%) | |
61 | LOCAL car%, caar% | |
62 | IF NOT FNis_pair(ast%) THEN =FNalloc_list2(FNalloc_symbol("quote"), ast%) | |
f14770fc | 63 | car% = FNfirst(ast%) |
df784d97 | 64 | IF FNis_symbol(car%) THEN |
f14770fc | 65 | IF FNunbox_symbol(car%) = "unquote" THEN =FNnth(ast%, 1) |
df784d97 BH |
66 | ENDIF |
67 | IF FNis_pair(car%) THEN | |
f14770fc | 68 | caar% = FNfirst(car%) |
df784d97 BH |
69 | IF FNis_symbol(caar%) THEN |
70 | IF FNunbox_symbol(caar%) = "splice-unquote" THEN | |
f14770fc | 71 | =FNalloc_list3(FNalloc_symbol("concat"), FNnth(car%, 1), FNquasiquote(FNrest(ast%))) |
df784d97 BH |
72 | ENDIF |
73 | ENDIF | |
74 | ENDIF | |
f14770fc | 75 | =FNalloc_list3(FNalloc_symbol("cons"), FNquasiquote(car%), FNquasiquote(FNrest(ast%))) |
df784d97 BH |
76 | |
77 | DEF FNis_macro_call(ast%, env%) | |
78 | LOCAL car%, val% | |
79 | IF NOT FNis_list(ast%) THEN =FALSE | |
f14770fc | 80 | car% = FNfirst(ast%) |
df784d97 BH |
81 | IF NOT FNis_symbol(car%) THEN =FALSE |
82 | IF FNis_nil(FNenv_find(env%, car%)) THEN =FALSE | |
83 | val% = FNenv_get(env%, car%) | |
84 | =FNis_macro(val%) | |
85 | ||
86 | DEF FNmacroexpand(ast%, env%) | |
87 | LOCAL mac%, macenv%, macast% | |
88 | WHILE FNis_macro_call(ast%, env%) | |
89 | REM PRINT "expanded ";FNpr_str(ast%, TRUE); | |
f14770fc BH |
90 | mac% = FNenv_get(env%, FNfirst(ast%)) |
91 | macenv% = FNnew_env(FNfn_env(mac%), FNfn_params(mac%), FNrest(ast%)) | |
df784d97 BH |
92 | macast% = FNfn_ast(mac%) |
93 | ast% = FNEVAL(macast%, macenv%) | |
94 | REM PRINT " to ";FNpr_str(ast%, TRUE) | |
95 | ENDWHILE | |
96 | =ast% | |
97 | ||
5311f069 BH |
98 | DEF FNtry_catch(ast%, env%) |
99 | LOCAL is_error%, ret% | |
100 | REM If there's no 'catch*' clause then we just evaluate the 'try*'. | |
f14770fc BH |
101 | IF FNcount(ast%) < 3 THEN =FNEVAL(FNnth(ast%, 1), env%) |
102 | IF FNunbox_symbol(FNfirst(FNnth(ast%, 2))) <> "catch*" THEN | |
5311f069 | 103 | ERROR &40E80924, "Invalid 'catch*' clause" |
df784d97 | 104 | ENDIF |
f14770fc BH |
105 | ret% = FNtry(FNnth(ast%, 1), env%, is_error%) |
106 | IF is_error% THEN =FNcatch(FNnth(ast%, 2), env%, ret%) | |
5311f069 BH |
107 | =ret% |
108 | ||
109 | REM Evaluate an expression, returning either the result or an exception | |
110 | REM raised during evaluation. is_error% indicates which it was. | |
111 | DEF FNtry(ast%, env%, RETURN is_error%) | |
112 | LOCAL trysav% | |
113 | trysav% = FNgc_save | |
114 | is_error% = FALSE | |
115 | LOCAL ERROR | |
116 | ON ERROR LOCAL is_error% = TRUE : =FNgc_restore(trysav%, FNwrap_exception) | |
117 | =FNgc_restore(trysav%, FNEVAL(ast%, env%)) | |
df784d97 | 118 | |
5311f069 BH |
119 | REM Return a mal value corresponding to the most-recently thrown exception. |
120 | DEF FNwrap_exception | |
347af951 BH |
121 | REM There are three cases to handle. When the error was generated |
122 | REM by 'throw', we should return the value that 'throw' stashed in | |
123 | REM MAL_ERR%. When the error was generated by mal, we should just | |
124 | REM return the error message. When the error was generated by BASIC | |
125 | REM or the OS, we should wrap the message and the error number in | |
126 | REM a hash-map. | |
5311f069 | 127 | IF ERR = &40E80900 THEN =MAL_ERR% : REM Error generated by 'throw' |
347af951 BH |
128 | IF (ERR AND &FFFFFF00) = &40E80900 THEN =FNalloc_string(REPORT$) |
129 | LOCAL e% | |
130 | e% = FNhashmap_set(FNempty_hashmap, "err", FNalloc_int(ERR)) | |
131 | =FNhashmap_set(e%, "message", FNalloc_string(REPORT$)) | |
5311f069 BH |
132 | |
133 | DEF FNcatch(ast%, env%, err%) | |
df784d97 | 134 | LOCAL binds%, exprs% |
f14770fc | 135 | binds% = FNalloc_pair(FNnth(ast%, 1), FNempty) |
5311f069 | 136 | exprs% = FNalloc_pair(err%, FNempty) |
df784d97 | 137 | env% = FNnew_env(env%, binds%, exprs%) |
f14770fc | 138 | =FNEVAL(FNnth(ast%, 2), env%) |
df784d97 BH |
139 | |
140 | DEF FNEVAL(ast%, env%) | |
141 | PROCgc_enter | |
142 | =FNgc_exit(FNEVAL_(ast%, env%)) | |
143 | ||
144 | DEF FNEVAL_(ast%, env%) | |
145 | LOCAL car%, specialform%, val%, bindings% | |
146 | REPEAT | |
147 | PROCgc_keep_only2(ast%, env%) | |
148 | IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) | |
149 | IF FNis_empty(ast%) THEN =ast% | |
150 | ast% = FNmacroexpand(ast%, env%) | |
151 | IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) | |
f14770fc | 152 | car% = FNfirst(ast%) |
df784d97 BH |
153 | specialform% = FALSE |
154 | IF FNis_symbol(car%) THEN | |
155 | specialform% = TRUE | |
156 | CASE FNunbox_symbol(car%) OF | |
157 | REM Special forms | |
158 | WHEN "def!" | |
f14770fc BH |
159 | val% = FNEVAL(FNnth(ast%, 2), env%) |
160 | PROCenv_set(env%, FNnth(ast%, 1), val%) | |
df784d97 BH |
161 | =val% |
162 | WHEN "defmacro!" | |
f14770fc | 163 | val% = FNEVAL(FNnth(ast%, 2), env%) |
90d90dfd | 164 | IF FNis_fn(val%) THEN val% = FNas_macro(val%) |
f14770fc | 165 | PROCenv_set(env%, FNnth(ast%, 1), val%) |
df784d97 BH |
166 | =val% |
167 | WHEN "let*" | |
168 | env% = FNalloc_environment(env%) | |
f14770fc | 169 | bindings% = FNnth(ast%, 1) |
df784d97 | 170 | WHILE NOT FNis_empty(bindings%) |
f14770fc BH |
171 | PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) |
172 | bindings% = FNrest(FNrest(bindings%)) | |
df784d97 | 173 | ENDWHILE |
f14770fc | 174 | ast% = FNnth(ast%, 2) |
df784d97 BH |
175 | REM Loop round for tail-call optimisation. |
176 | WHEN "do" | |
177 | REM The guide has us call FNeval_ast on the sub-list that excludes | |
178 | REM the last element of ast%, but that's a bit painful without | |
179 | REM native list slicing, so it's easier to just re-implement the | |
180 | REM bit of FNeval_ast that we need. | |
f14770fc BH |
181 | ast% = FNrest(ast%) |
182 | WHILE NOT FNis_empty(FNrest(ast%)) | |
183 | val% = FNEVAL(FNfirst(ast%), env%) | |
184 | ast% = FNrest(ast%) | |
df784d97 | 185 | ENDWHILE |
f14770fc | 186 | ast% = FNfirst(ast%) |
df784d97 | 187 | WHEN "if" |
f14770fc BH |
188 | IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN |
189 | ast% = FNnth(ast%, 2) | |
df784d97 | 190 | ELSE |
f14770fc | 191 | IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3) |
df784d97 BH |
192 | ENDIF |
193 | REM Loop round for tail-call optimisation. | |
194 | WHEN "fn*" | |
f14770fc | 195 | =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) |
df784d97 | 196 | WHEN "quote" |
f14770fc | 197 | =FNnth(ast%, 1) |
df784d97 | 198 | WHEN "quasiquote" |
f14770fc | 199 | ast% = FNquasiquote(FNnth(ast%, 1)) |
df784d97 BH |
200 | REM Loop round for tail-call optimisation |
201 | WHEN "macroexpand" | |
f14770fc | 202 | =FNmacroexpand(FNnth(ast%, 1), env%) |
df784d97 | 203 | WHEN "try*" |
5311f069 | 204 | =FNtry_catch(ast%, env%) |
df784d97 BH |
205 | OTHERWISE |
206 | specialform% = FALSE | |
207 | ENDCASE | |
208 | ENDIF | |
209 | IF NOT specialform% THEN | |
210 | REM This is the "apply" part. | |
211 | ast% = FNeval_ast(ast%, env%) | |
f14770fc | 212 | car% = FNfirst(ast%) |
df784d97 | 213 | IF FNis_corefn(car%) THEN |
f14770fc | 214 | =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) |
df784d97 BH |
215 | ENDIF |
216 | IF FNis_fn(car%) THEN | |
f14770fc | 217 | env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) |
df784d97 BH |
218 | ast% = FNfn_ast(car%) |
219 | REM Loop round for tail-call optimisation. | |
220 | ELSE | |
221 | ERROR &40E80918, "Not a function" | |
222 | ENDIF | |
223 | ENDIF | |
224 | UNTIL FALSE | |
225 | ||
226 | DEF FNPRINT(a%) | |
0f97a00d | 227 | =FNunbox_string(FNpr_str(a%, TRUE)) |
df784d97 BH |
228 | |
229 | DEF FNrep(a$) | |
230 | =FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) | |
231 | ||
232 | DEF FNeval_ast(ast%, env%) | |
08bb33c1 | 233 | LOCAL val%, car%, cdr%, map%, keys%, key$ |
df784d97 | 234 | IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) |
9152704f | 235 | IF FNis_seq(ast%) THEN |
df784d97 | 236 | IF FNis_empty(ast%) THEN =ast% |
f14770fc BH |
237 | car% = FNEVAL(FNfirst(ast%), env%) |
238 | cdr% = FNeval_ast(FNrest(ast%), env%) | |
9152704f | 239 | IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) |
df784d97 BH |
240 | =FNalloc_pair(car%, cdr%) |
241 | ENDIF | |
08bb33c1 BH |
242 | IF FNis_hashmap(ast%) THEN |
243 | map% = FNempty_hashmap | |
244 | keys% = FNhashmap_keys(ast%) | |
245 | WHILE NOT FNis_empty(keys%) | |
246 | key$ = FNunbox_string(FNfirst(keys%)) | |
247 | map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) | |
248 | keys% = FNrest(keys%) | |
249 | ENDWHILE | |
250 | =map% | |
251 | ENDIF | |
df784d97 BH |
252 | =ast% |
253 | ||
cbc6f3fb BH |
254 | DEF FNget_argv |
255 | PROCgc_enter | |
a445b499 | 256 | LOCAL argv%, rargv%, cmdptr%, arg$, len% |
cbc6f3fb BH |
257 | argv% = FNempty |
258 | IF !PAGE = &D7C1C7C5 THEN | |
259 | REM Running under Brandy, so ARGC and ARGV$ are usable. | |
260 | IF ARGC >= 1 THEN | |
261 | FOR i% = ARGC TO 1 STEP -1 | |
262 | argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%) | |
263 | NEXT i% | |
264 | ENDIF | |
a445b499 BH |
265 | ELSE |
266 | IF (INKEY(-256) AND &F0) = &A0 THEN | |
267 | rargv% = FNempty | |
268 | REM Running under RISC OS | |
269 | REM Vexingly, we can only get the command line that was passed to | |
270 | REM the BASIC interpreter. This means that we need to extract | |
271 | REM the arguments from that. Typically, we will have been started | |
272 | REM with "BASIC -quit <filename> <args>". | |
273 | ||
274 | DIM q% 256 | |
275 | SYS "OS_GetEnv" TO cmdptr% | |
276 | WHILE ?cmdptr% >= 32 | |
277 | SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len% | |
278 | q%?len% = 13 | |
279 | rargv% = FNalloc_pair(FNalloc_string($q%), rargv%) | |
280 | ENDWHILE | |
281 | REM Put argv back into the right order. | |
282 | WHILE NOT FNis_empty(rargv%) | |
283 | argv% = FNalloc_pair(FNfirst(rargv%), argv%) | |
284 | rargv% = FNrest(rargv%) | |
285 | ENDWHILE | |
286 | IF FNis_empty(argv%) THEN =FNgc_exit(argv%) | |
287 | argv% = FNrest(argv%) : REM skip "BASIC" | |
288 | IF FNis_empty(argv%) THEN =FNgc_exit(argv%) | |
289 | IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%) | |
290 | argv% = FNrest(argv%) : REM skip "-quit" | |
291 | IF FNis_empty(argv%) THEN =FNgc_exit(argv%) | |
292 | argv% = FNrest(argv%) : REM skip filename | |
293 | ENDIF | |
cbc6f3fb BH |
294 | ENDIF |
295 | =FNgc_exit(argv%) | |
296 | ||
297 | ||
df784d97 BH |
298 | REM Local Variables: |
299 | REM indent-tabs-mode: nil | |
300 | REM End: |