bbc-basic/step3_env.bbc

   1 REM Step 3 of mal in BBC BASIC
   2
   3 LIBRARY "types"
   4 LIBRARY "reader"
   5 LIBRARY "printer"
   6 LIBRARY "env"
   7
   8 PROCtypes_init
   9
  10 REM  These correspond with the CASE statement in FNcore_call
  11 repl_env% = FNalloc_environment(FNnil)
  12 PROCenv_set(repl_env%, FNalloc_symbol("+"), FNalloc_corefn(0))
  13 PROCenv_set(repl_env%, FNalloc_symbol("-"), FNalloc_corefn(1))
  14 PROCenv_set(repl_env%, FNalloc_symbol("*"), FNalloc_corefn(2))
  15 PROCenv_set(repl_env%, FNalloc_symbol("/"), FNalloc_corefn(3))
  16
  17 REPEAT
  18   REM  Catch all errors apart from "Escape".
  19   ON ERROR LOCAL PRINT REPORT$:IF ERR = 17 THEN END ELSE PROCgc_restore(sav%)
  20   sav% = FNgc_save
  21   PRINT "user> ";
  22   LINE INPUT "" line$
  23   PRINT FNrep(line$)
  24   PROCgc_restore(sav%)
  25 UNTIL FALSE
  26
  27 END
  28
  29 DEF FNREAD(a$)
  30 =FNread_str(a$)
  31
  32 DEF FNEVAL(ast%, env%)
  33   LOCAL car%
  34   IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
  35   IF FNis_empty(ast%) THEN =ast%
  36   car% = FNfirst(ast%)
  37   IF FNis_symbol(car%) THEN
  38     CASE FNunbox_symbol(car%) OF
  39       REM  Special forms
  40       WHEN "def!"
  41         LOCAL val%
  42         val% = FNEVAL(FNnth(ast%, 2), env%)
  43         PROCenv_set(env%, FNnth(ast%, 1), val%)
  44         =val%
  45       WHEN "let*"
  46         LOCAL bindings%
  47         env% = FNalloc_environment(env%)
  48         bindings% = FNnth(ast%, 1)
  49         WHILE NOT FNis_empty(bindings%)
  50           PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%))
  51           bindings% = FNrest(FNrest(bindings%))
  52         ENDWHILE
  53         =FNEVAL(FNnth(ast%, 2), env%)
  54     ENDCASE
  55   ENDIF
  56   ast% = FNeval_ast(ast%, env%)
  57 =FNcore_call(FNunbox_corefn(FNfirst(ast%)), FNrest(ast%))
  58
  59 DEF FNPRINT(a%)
  60 =FNpr_str(a%, TRUE)
  61
  62 DEF FNrep(a$)
  63 =FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
  64
  65 DEF FNeval_ast(ast%, env%)
  66   LOCAL val%, car%, cdr%, map%, keys%, key$
  67   IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
  68   IF FNis_seq(ast%) THEN
  69     IF FNis_empty(ast%) THEN =ast%
  70     car% = FNEVAL(FNfirst(ast%), env%)
  71     cdr% = FNeval_ast(FNrest(ast%), env%)
  72     IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
  73     =FNalloc_pair(car%, cdr%)
  74   ENDIF
  75   IF FNis_hashmap(ast%) THEN
  76     map% = FNempty_hashmap
  77     keys% = FNhashmap_keys(ast%)
  78     WHILE NOT FNis_empty(keys%)
  79       key$ = FNunbox_string(FNfirst(keys%))
  80       map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
  81       keys% = FNrest(keys%)
  82     ENDWHILE
  83     =map%
  84   ENDIF
  85 =ast%
  86
  87 REM  Call a core function, taking the function number and a mal list of
  88 REM  objects to pass as arguments.
  89 DEF FNcore_call(fn%, args%)
  90   LOCAL x%, y%, z%
  91   x% = FNunbox_int(FNfirst(args%))
  92   y% = FNunbox_int(FNfirst(FNrest(args%)))
  93   CASE fn% OF
  94     WHEN 0 : z% = x%  +  y%
  95     WHEN 1 : z% = x%  -  y%
  96     WHEN 2 : z% = x%  *  y%
  97     WHEN 3 : z% = x% DIV y%
  98     OTHERWISE : ERROR &40E809F1, "Call to non-existent core function"
  99   ENDCASE
 100 =FNalloc_int(z%)
 101
 102 REM Local Variables:
 103 REM indent-tabs-mode: nil
 104 REM End: