REM Step 9 of mal in BBC BASIC LIBRARY "types" LIBRARY "reader" LIBRARY "printer" LIBRARY "env" LIBRARY "core" PROCtypes_init repl_env% = FNalloc_environment(FNnil) PROCcore_ns : REM This sets the data pointer REPEAT READ sym$, i% IF sym$ <> "" THEN PROCenv_set(repl_env%, sym$, FNalloc_corefn(i%)) ENDIF UNTIL sym$ = "" REM Initial forms to evaluate RESTORE +0 DATA (def! not (fn* (a) (if a false true))) DATA (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) 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))))))) DATA "" REPEAT READ form$ IF form$ <> "" THEN val$ = FNrep(form$) UNTIL form$ = "" argv% = FNget_argv IF FNis_empty(argv%) THEN PROCenv_set(repl_env%, "*ARGV*", FNempty) ELSE PROCenv_set(repl_env%, "*ARGV*", FNrest(argv%)) val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")") END ENDIF sav% = FNgc_save REPEAT REM Catch all errors apart from "Escape". ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ PROCgc_restore(sav%) sav% = FNgc_save PRINT "user> "; LINE INPUT "" line$ PRINT FNrep(line$) UNTIL FALSE END DEF FNREAD(a$) =FNread_str(FNalloc_string(a$)) DEF FNstarts_with(ast%, sym$) LOCAL a0% IF NOT FNis_list(ast%) THEN =FALSE a0% = FNfirst(ast%) IF NOT FNis_symbol(a0%) THEN =FALSE =FNunbox_symbol(a0%) = sym$ DEF FNqq_elts(seq%) LOCAL elt%, acc% IF FNis_empty(seq%) THEN =FNempty elt% = FNfirst(seq%) acc% = FNqq_elts(FNrest(seq%)) IF FNstarts_with(elt%, "splice-unquote") THEN =FNalloc_list3(FNalloc_symbol("concat"), FNnth(elt%, 1), acc%) ENDIF =FNalloc_list3(FNalloc_symbol("cons"), FNquasiquote(elt%), acc%) DEF FNquasiquote(ast%) IF FNstarts_with(ast%, "unquote") THEN =FNnth(ast%, 1) IF FNis_list(ast%) THEN =FNqq_elts(ast%) IF FNis_vector(ast%) THEN =FNalloc_list2(FNalloc_symbol("vec"), FNqq_elts(ast%)) ENDIF IF FNis_symbol(ast%) OR FNis_hashmap(ast%) THEN =FNalloc_list2(FNalloc_symbol("quote"), ast%) ENDIF =ast% DEF FNtry_catch(ast%, env%) LOCAL is_error%, ret% REM If there's no 'catch*' clause then we just evaluate the 'try*'. IF FNcount(ast%) < 3 THEN =FNEVAL(FNnth(ast%, 1), env%) IF FNunbox_symbol(FNfirst(FNnth(ast%, 2))) <> "catch*" THEN ERROR &40E80924, "Invalid 'catch*' clause" ENDIF ret% = FNtry(FNnth(ast%, 1), env%, is_error%) IF is_error% THEN =FNcatch(FNnth(ast%, 2), env%, ret%) =ret% REM Evaluate an expression, returning either the result or an exception REM raised during evaluation. is_error% indicates which it was. DEF FNtry(ast%, env%, RETURN is_error%) LOCAL trysav% trysav% = FNgc_save is_error% = FALSE LOCAL ERROR ON ERROR LOCAL is_error% = TRUE : =FNgc_restore(trysav%, FNwrap_exception) =FNgc_restore(trysav%, FNEVAL(ast%, env%)) REM Return a mal value corresponding to the most-recently thrown exception. DEF FNwrap_exception REM There are three cases to handle. When the error was generated REM by 'throw', we should return the value that 'throw' stashed in REM MAL_ERR%. When the error was generated by mal, we should just REM return the error message. When the error was generated by BASIC REM or the OS, we should wrap the message and the error number in REM a hash-map. IF ERR = &40E80900 THEN =MAL_ERR% : REM Error generated by 'throw' IF (ERR AND &FFFFFF00) = &40E80900 THEN =FNalloc_string(REPORT$) LOCAL e% e% = FNhashmap_set(FNempty_hashmap, "err", FNalloc_int(ERR)) =FNhashmap_set(e%, "message", FNalloc_string(REPORT$)) DEF FNcatch(ast%, env%, err%) LOCAL binds%, exprs% binds% = FNalloc_pair(FNnth(ast%, 1), FNempty) exprs% = FNalloc_pair(err%, FNempty) env% = FNnew_env(env%, binds%, exprs%) =FNEVAL(FNnth(ast%, 2), env%) DEF FNEVAL(ast%, env%) PROCgc_enter =FNgc_exit(FNEVAL_(ast%, env%)) DEF FNEVAL_(ast%, env%) LOCAL car%, val%, bindings%, key$ 31416 REM tail call optimization loop PROCgc_keep_only2(ast%, env%) val% = FNenv_find(env%, "DEBUG-EVAL") IF NOT FNis_nil(val%) THEN IF FNis_truish(FNenv_get(val%, "DEBUG-EVAL")) THEN PRINT "EVAL: " + FNunbox_string(FNpr_str(ast%, TRUE)) ENDIF ENDIF IF FNis_symbol(ast%) THEN =FNenv_get(env%, FNunbox_symbol(ast%)) IF FNis_hashmap(ast%) THEN val% = FNempty_hashmap bindings% = FNhashmap_keys(ast%) WHILE NOT FNis_empty(bindings%) key$ = FNunbox_string(FNfirst(bindings%)) val% = FNhashmap_set(val%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) bindings% = FNrest(bindings%) ENDWHILE =val% ENDIF IF NOT FNis_seq(ast%) THEN =ast% IF FNis_empty(ast%) THEN =ast% car% = FNfirst(ast%) IF FNis_vector(ast%) THEN =FNalloc_vector_pair(FNEVAL(car%, env%), FNeval_ast(FNrest(ast%), env%)) IF FNis_symbol(car%) THEN key$ = FNunbox_symbol(car%) CASE key$ OF REM Special forms WHEN "def!" val% = FNEVAL(FNnth(ast%, 2), env%) PROCenv_set(env%, FNunbox_symbol(FNnth(ast%, 1)), val%) =val% WHEN "defmacro!" val% = FNEVAL(FNnth(ast%, 2), env%) IF FNis_fn(val%) THEN val% = FNas_macro(val%) PROCenv_set(env%, FNunbox_symbol(FNnth(ast%, 1)), val%) =val% WHEN "let*" env% = FNalloc_environment(env%) bindings% = FNnth(ast%, 1) WHILE NOT FNis_empty(bindings%) PROCenv_set(env%, FNunbox_symbol(FNfirst(bindings%)), FNEVAL(FNnth(bindings%, 1), env%)) bindings% = FNrest(FNrest(bindings%)) ENDWHILE ast% = FNnth(ast%, 2) GOTO 31416 WHEN "do" REM The guide has us call FNeval_ast on the sub-list that excludes REM the last element of ast%, but that's a bit painful without REM native list slicing, so it's easier to just re-implement the REM bit of FNeval_ast that we need. ast% = FNrest(ast%) WHILE NOT FNis_empty(FNrest(ast%)) val% = FNEVAL(FNfirst(ast%), env%) ast% = FNrest(ast%) ENDWHILE ast% = FNfirst(ast%) GOTO 31416 WHEN "if" IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN ast% = FNnth(ast%, 2) ELSE IF FNcount(ast%) = 3 THEN =FNnil ast% = FNnth(ast%, 3) ENDIF GOTO 31416 WHEN "fn*" =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) WHEN "quote" =FNnth(ast%, 1) WHEN "quasiquote" ast% = FNquasiquote(FNnth(ast%, 1)) GOTO 31416 WHEN "try*" =FNtry_catch(ast%, env%) OTHERWISE car% = FNenv_get(env%, key$) ENDCASE ELSE car% = FNEVAL(car%, env%) ENDIF REM This is the "apply" part. ast% = FNrest(ast%) IF FNis_macro(car%) THEN ast% = FNEVAL(FNfn_ast(car%), FNnew_env(FNfn_env(car%), FNfn_params(car%), ast%)) GOTO 31416 ENDIF ast% = FNeval_ast(ast%, env%) IF FNis_corefn(car%) THEN =FNcore_call(FNunbox_corefn(car%), ast%) ENDIF IF FNis_fn(car%) THEN env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), ast%) ast% = FNfn_ast(car%) GOTO 31416 ENDIF ERROR &40E80918, "Not a function" DEF FNPRINT(a%) =FNunbox_string(FNpr_str(a%, TRUE)) DEF FNrep(a$) =FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) DEF FNeval_ast(ast%, env%) IF FNis_empty(ast%) THEN =ast% =FNalloc_pair(FNEVAL(FNfirst(ast%), env%), FNeval_ast(FNrest(ast%), env%)) DEF FNget_argv PROCgc_enter LOCAL argv%, rargv%, cmdptr%, arg$, len% argv% = FNempty IF !PAGE = &D7C1C7C5 THEN REM Running under Brandy, so ARGC and ARGV$ are usable. IF ARGC >= 1 THEN FOR i% = ARGC TO 1 STEP -1 argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%) NEXT i% ENDIF ELSE IF (INKEY(-256) AND &F0) = &A0 THEN rargv% = FNempty REM Running under RISC OS REM Vexingly, we can only get the command line that was passed to REM the BASIC interpreter. This means that we need to extract REM the arguments from that. Typically, we will have been started REM with "BASIC -quit ". DIM q% 256 SYS "OS_GetEnv" TO cmdptr% WHILE ?cmdptr% >= 32 SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len% q%?len% = 13 rargv% = FNalloc_pair(FNalloc_string($q%), rargv%) ENDWHILE REM Put argv back into the right order. WHILE NOT FNis_empty(rargv%) argv% = FNalloc_pair(FNfirst(rargv%), argv%) rargv% = FNrest(rargv%) ENDWHILE IF FNis_empty(argv%) THEN =FNgc_exit(argv%) argv% = FNrest(argv%) : REM skip "BASIC" IF FNis_empty(argv%) THEN =FNgc_exit(argv%) IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%) argv% = FNrest(argv%) : REM skip "-quit" IF FNis_empty(argv%) THEN =FNgc_exit(argv%) argv% = FNrest(argv%) : REM skip filename ENDIF ENDIF =FNgc_exit(argv%) REM Local Variables: REM indent-tabs-mode: nil REM End: