REM Step 4 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%, FNalloc_symbol(sym$), FNalloc_corefn(i%))
  ENDIF
UNTIL sym$ = ""

val$ = FNrep("(def! not (fn* (a) (if a false true)))")

REPEAT
  REM  Catch all errors apart from "Escape".
  ON ERROR LOCAL PRINT REPORT$:IF ERR = 17 THEN END ELSE PROCgc_restore(sav%)
  sav% = FNgc_save
  PRINT "user> ";
  LINE INPUT "" line$
  PRINT FNrep(line$)
  PROCgc_restore(sav%)
UNTIL FALSE

END

DEF FNREAD(a$)
=FNread_str(a$)

DEF FNEVAL(ast%, env%)
  PROCgc
  PROCgc_enter
=FNgc_exit(FNEVAL_(ast%, env%))

DEF FNEVAL_(ast%, env%)
  LOCAL car%
  IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
  IF FNis_empty(ast%) THEN =ast%
  car% = FNlist_car(ast%)
  IF FNis_symbol(car%) THEN
    CASE FNunbox_symbol(car%) OF
      REM  Special forms
      WHEN "def!"
        LOCAL val%
	val% = FNEVAL(FNlist_nth(ast%, 2), env%)
        PROCenv_set(env%, FNlist_nth(ast%, 1), val%)
	=val%
      WHEN "let*"
        LOCAL bindings%
	env% = FNalloc_environment(env%)
	bindings% = FNlist_nth(ast%, 1)
	WHILE NOT FNis_empty(bindings%)
	  PROCenv_set(env%, FNlist_car(bindings%), FNEVAL(FNlist_nth(bindings%, 1), env%))
	  bindings% = FNlist_cdr(FNlist_cdr(bindings%))
	ENDWHILE
	=FNEVAL(FNlist_nth(ast%, 2), env%)
      WHEN "do"
        LOCAL val%
        ast% = FNeval_ast(FNlist_cdr(ast%), env%)
	REPEAT
	  val% = FNlist_car(ast%)
	  ast% = FNlist_cdr(ast%)
	UNTIL FNis_empty(ast%)
	=val%
      WHEN "if"
        IF FNis_truish(FNEVAL(FNlist_nth(ast%, 1), env%)) THEN
	  =FNEVAL(FNlist_nth(ast%, 2), env%)
	ENDIF
	IF FNlist_len(ast%) = 3 THEN =FNnil
	=FNEVAL(FNlist_nth(ast%, 3), env%)
      WHEN "fn*"
	=FNalloc_fn(FNlist_nth(ast%, 2), FNlist_nth(ast%, 1), env%)
    ENDCASE
  ENDIF
  ast% = FNeval_ast(ast%, env%)
  car% = FNlist_car(ast%)
  IF FNis_fn(car%) THEN
    env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNlist_cdr(ast%))
    =FNEVAL(FNfn_ast(car%), env%)
  ENDIF
  IF FNis_corefn(car%) THEN
    =FNcore_call(FNunbox_corefn(car%), FNlist_cdr(ast%))
  ENDIF
  ERROR &40E80918, "Not a function"

DEF FNPRINT(a%)
=FNpr_str(a%, TRUE)

DEF FNrep(a$)
=FNPRINT(FNEVAL(FNREAD(a$), repl_env%))

DEF FNeval_ast(ast%, env%)
  LOCAL val%, car%, cdr%
  IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
  IF FNis_list(ast%) THEN
    IF FNis_empty(ast%) THEN =ast%
    car% = FNEVAL(FNlist_car(ast%), env%)
    cdr% = FNeval_ast(FNlist_cdr(ast%), env%)
    =FNalloc_pair(car%, cdr%)
  ENDIF
=ast%

REM Local Variables:
REM indent-tabs-mode: nil
REM End: