bbc-basic/step4_if_fn_do.bas

   1 REM Step 4 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 val$ = FNrep("(def! not (fn* (a) (if a false true)))")
  21
  22 sav% = FNgc_save
  23 REPEAT
  24   REM  Catch all errors apart from "Escape".
  25   ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$
  26   PROCgc_restore(sav%)
  27   sav% = FNgc_save
  28   PRINT "user> ";
  29   LINE INPUT "" line$
  30   PRINT FNrep(line$)
  31 UNTIL FALSE
  32
  33 END
  34
  35 DEF FNREAD(a$)
  36 =FNread_str(FNalloc_string(a$))
  37
  38 DEF FNEVAL(ast%, env%)
  39   PROCgc
  40   PROCgc_enter
  41 =FNgc_exit(FNEVAL_(ast%, env%))
  42
  43 DEF FNEVAL_(ast%, env%)
  44   LOCAL car%
  45   IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
  46   IF FNis_empty(ast%) THEN =ast%
  47   car% = FNfirst(ast%)
  48   IF FNis_symbol(car%) THEN
  49     CASE FNunbox_symbol(car%) OF
  50       REM  Special forms
  51       WHEN "def!"
  52         LOCAL val%
  53         val% = FNEVAL(FNnth(ast%, 2), env%)
  54         PROCenv_set(env%, FNnth(ast%, 1), val%)
  55         =val%
  56       WHEN "let*"
  57         LOCAL bindings%
  58         env% = FNalloc_environment(env%)
  59         bindings% = FNnth(ast%, 1)
  60         WHILE NOT FNis_empty(bindings%)
  61           PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%))
  62           bindings% = FNrest(FNrest(bindings%))
  63         ENDWHILE
  64         =FNEVAL(FNnth(ast%, 2), env%)
  65       WHEN "do"
  66         LOCAL val%
  67         ast% = FNeval_ast(FNrest(ast%), env%)
  68         REPEAT
  69           val% = FNfirst(ast%)
  70           ast% = FNrest(ast%)
  71         UNTIL FNis_empty(ast%)
  72         =val%
  73       WHEN "if"
  74         IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN
  75           =FNEVAL(FNnth(ast%, 2), env%)
  76         ENDIF
  77         IF FNcount(ast%) = 3 THEN =FNnil
  78         =FNEVAL(FNnth(ast%, 3), env%)
  79       WHEN "fn*"
  80         =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%)
  81     ENDCASE
  82   ENDIF
  83   ast% = FNeval_ast(ast%, env%)
  84   car% = FNfirst(ast%)
  85   IF FNis_fn(car%) THEN
  86     env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%))
  87     =FNEVAL(FNfn_ast(car%), env%)
  88   ENDIF
  89   IF FNis_corefn(car%) THEN
  90     =FNcore_call(FNunbox_corefn(car%), FNrest(ast%))
  91   ENDIF
  92   ERROR &40E80918, "Not a function"
  93
  94 DEF FNPRINT(a%)
  95 =FNunbox_string(FNpr_str(a%, TRUE))
  96
  97 DEF FNrep(a$)
  98 =FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
  99
 100 DEF FNeval_ast(ast%, env%)
 101   LOCAL val%, car%, cdr%, map%, keys%, key$
 102   IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
 103   IF FNis_seq(ast%) THEN
 104     IF FNis_empty(ast%) THEN =ast%
 105     car% = FNEVAL(FNfirst(ast%), env%)
 106     cdr% = FNeval_ast(FNrest(ast%), env%)
 107     IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
 108     =FNalloc_pair(car%, cdr%)
 109   ENDIF
 110   IF FNis_hashmap(ast%) THEN
 111     map% = FNempty_hashmap
 112     keys% = FNhashmap_keys(ast%)
 113     WHILE NOT FNis_empty(keys%)
 114       key$ = FNunbox_string(FNfirst(keys%))
 115       map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
 116       keys% = FNrest(keys%)
 117     ENDWHILE
 118     =map%
 119   ENDIF
 120 =ast%
 121
 122 REM Local Variables:
 123 REM indent-tabs-mode: nil
 124 REM End: