bbc-basic: Adjust error message from FNenv_get to match tests.

[jackhill/mal.git] / bbc-basic / step8_macros.bbc

REM Step 8 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$ = ""

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) ")")))))
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 (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))
DATA ""
REPEAT
  READ form$
  IF form$ <> "" THEN val$ = FNrep(form$)
UNTIL form$ = ""

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

END

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

DEF FNis_pair(val%)
=FNis_list(val%) AND NOT FNis_empty(val%)

DEF FNquasiquote(ast%)
  LOCAL car%, caar%
  IF NOT FNis_pair(ast%) THEN =FNalloc_list2(FNalloc_symbol("quote"), ast%)
  car% = FNlist_car(ast%)
  IF FNis_symbol(car%) THEN
    IF FNunbox_symbol(car%) = "unquote" THEN =FNlist_nth(ast%, 1)
  ENDIF
  IF FNis_pair(car%) THEN
    caar% = FNlist_car(car%)
    IF FNis_symbol(caar%) THEN
      IF FNunbox_symbol(caar%) = "splice-unquote" THEN
        =FNalloc_list3(FNalloc_symbol("concat"), FNlist_nth(car%, 1), FNquasiquote(FNlist_cdr(ast%)))
      ENDIF
    ENDIF
  ENDIF
=FNalloc_list3(FNalloc_symbol("cons"), FNquasiquote(car%), FNquasiquote(FNlist_cdr(ast%)))

DEF FNis_macro_call(ast%, env%)
  LOCAL car%, val%
  IF NOT FNis_list(ast%) THEN =FALSE
  car% = FNlist_car(ast%)
  IF NOT FNis_symbol(car%) THEN =FALSE
  IF FNis_nil(FNenv_find(env%, car%)) THEN =FALSE
  val% = FNenv_get(env%, car%)
=FNis_macro(val%)

DEF FNmacroexpand(ast%, env%)
  LOCAL mac%, macenv%, macast%
  WHILE FNis_macro_call(ast%, env%)
    REM PRINT "expanded ";FNpr_str(ast%, TRUE);
    mac% = FNenv_get(env%, FNlist_car(ast%))
    macenv% = FNnew_env(FNfn_env(mac%), FNfn_params(mac%), FNlist_cdr(ast%))
    macast% = FNfn_ast(mac%)
    ast% = FNEVAL(macast%, macenv%)
    REM PRINT " to ";FNpr_str(ast%, TRUE)
  ENDWHILE
=ast%

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

DEF FNEVAL_(ast%, env%)
  LOCAL car%, specialform%, val%, bindings%
  REPEAT
    PROCgc_keep_only2(ast%, env%)
    IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
    IF FNis_empty(ast%) THEN =ast%
    ast% = FNmacroexpand(ast%, env%)
    IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
    car% = FNlist_car(ast%)
    specialform% = FALSE
    IF FNis_symbol(car%) THEN
      specialform% = TRUE
      CASE FNunbox_symbol(car%) OF
        REM  Special forms
        WHEN "def!"
          val% = FNEVAL(FNlist_nth(ast%, 2), env%)
          PROCenv_set(env%, FNlist_nth(ast%, 1), val%)
          =val%
        WHEN "defmacro!"
          val% = FNEVAL(FNlist_nth(ast%, 2), env%)
          IF FNis_fn(val%) THEN PROCmake_macro(val%)
          PROCenv_set(env%, FNlist_nth(ast%, 1), val%)
          =val%
        WHEN "let*"
          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
          ast% = FNlist_nth(ast%, 2)
          REM  Loop round for tail-call optimisation.
        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% = FNlist_cdr(ast%)
          WHILE NOT FNis_empty(FNlist_cdr(ast%))
            val% = FNEVAL(FNlist_car(ast%), env%)
            ast% = FNlist_cdr(ast%)
          ENDWHILE
          ast% = FNlist_car(ast%)
        WHEN "if"
          IF FNis_truish(FNEVAL(FNlist_nth(ast%, 1), env%)) THEN
            ast% = FNlist_nth(ast%, 2)
          ELSE
            IF FNlist_len(ast%) = 3 THEN =FNnil ELSE ast% = FNlist_nth(ast%, 3)
          ENDIF
          REM  Loop round for tail-call optimisation.
        WHEN "fn*"
          =FNalloc_fn(FNlist_nth(ast%, 2), FNlist_nth(ast%, 1), env%)
        WHEN "quote"
          =FNlist_nth(ast%, 1)
        WHEN "quasiquote"
          ast% = FNquasiquote(FNlist_nth(ast%, 1))
          REM  Loop round for tail-call optimisation
        WHEN "macroexpand"
          =FNmacroexpand(FNlist_nth(ast%, 1), env%)
        OTHERWISE
          specialform% = FALSE
      ENDCASE
    ENDIF
    IF NOT specialform% THEN
      REM  This is the "apply" part.
      ast% = FNeval_ast(ast%, env%)
      car% = FNlist_car(ast%)
      IF FNis_corefn(car%) THEN
        =FNcore_call(FNunbox_corefn(car%), FNlist_cdr(ast%))
      ENDIF
      IF FNis_fn(car%) THEN
        env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNlist_cdr(ast%))
        ast% = FNfn_ast(car%)
        REM  Loop round for tail-call optimisation.
      ELSE
        ERROR &40E80918, "Not a function"
      ENDIF
    ENDIF
  UNTIL FALSE

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: