bbc-basic/step7_quote.bas

   1 REM Step 7 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 REM  Initial forms to evaluate
  21 RESTORE +0
  22 DATA (def! not (fn* (a) (if a false true)))
  23 DATA (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))
  24 DATA ""
  25 REPEAT
  26   READ form$
  27   IF form$ <> "" THEN val$ = FNrep(form$)
  28 UNTIL form$ = ""
  29
  30 argv% = FNget_argv
  31
  32 IF FNis_empty(argv%) THEN
  33   PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty)
  34 ELSE
  35   PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%))
  36   val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")")
  37   END
  38 ENDIF
  39
  40 sav% = FNgc_save
  41 REPEAT
  42   REM  Catch all errors apart from "Escape".
  43   ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$
  44   PROCgc_restore(sav%)
  45   sav% = FNgc_save
  46   PRINT "user> ";
  47   LINE INPUT "" line$
  48   PRINT FNrep(line$)
  49 UNTIL FALSE
  50
  51 END
  52
  53 DEF FNREAD(a$)
  54 =FNread_str(FNalloc_string(a$))
  55
  56 DEF FNis_pair(val%)
  57 =FNis_seq(val%) AND NOT FNis_empty(val%)
  58
  59 DEF FNquasiquote(ast%)
  60   LOCAL car%, caar%
  61   IF NOT FNis_pair(ast%) THEN =FNalloc_list2(FNalloc_symbol("quote"), ast%)
  62   car% = FNfirst(ast%)
  63   IF FNis_symbol(car%) THEN
  64     IF FNunbox_symbol(car%) = "unquote" THEN =FNnth(ast%, 1)
  65   ENDIF
  66   IF FNis_pair(car%) THEN
  67     caar% = FNfirst(car%)
  68     IF FNis_symbol(caar%) THEN
  69       IF FNunbox_symbol(caar%) = "splice-unquote" THEN
  70         =FNalloc_list3(FNalloc_symbol("concat"), FNnth(car%, 1), FNquasiquote(FNrest(ast%)))
  71       ENDIF
  72     ENDIF
  73   ENDIF
  74 =FNalloc_list3(FNalloc_symbol("cons"), FNquasiquote(car%), FNquasiquote(FNrest(ast%)))
  75
  76 DEF FNEVAL(ast%, env%)
  77   PROCgc_enter
  78 =FNgc_exit(FNEVAL_(ast%, env%))
  79
  80 DEF FNEVAL_(ast%, env%)
  81   LOCAL car%, specialform%, val%, bindings%
  82   REPEAT
  83     PROCgc_keep_only2(ast%, env%)
  84     IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
  85     IF FNis_empty(ast%) THEN =ast%
  86     car% = FNfirst(ast%)
  87     specialform% = FALSE
  88     IF FNis_symbol(car%) THEN
  89       specialform% = TRUE
  90       CASE FNunbox_symbol(car%) OF
  91         REM  Special forms
  92         WHEN "def!"
  93           val% = FNEVAL(FNnth(ast%, 2), env%)
  94           PROCenv_set(env%, FNnth(ast%, 1), val%)
  95           =val%
  96         WHEN "let*"
  97           env% = FNalloc_environment(env%)
  98           bindings% = FNnth(ast%, 1)
  99           WHILE NOT FNis_empty(bindings%)
 100             PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%))
 101             bindings% = FNrest(FNrest(bindings%))
 102           ENDWHILE
 103           ast% = FNnth(ast%, 2)
 104           REM  Loop round for tail-call optimisation.
 105         WHEN "do"
 106           REM  The guide has us call FNeval_ast on the sub-list that excludes
 107           REM  the last element of ast%, but that's a bit painful without
 108           REM  native list slicing, so it's easier to just re-implement the
 109           REM  bit of FNeval_ast that we need.
 110           ast% = FNrest(ast%)
 111           WHILE NOT FNis_empty(FNrest(ast%))
 112             val% = FNEVAL(FNfirst(ast%), env%)
 113             ast% = FNrest(ast%)
 114           ENDWHILE
 115           ast% = FNfirst(ast%)
 116         WHEN "if"
 117           IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN
 118             ast% = FNnth(ast%, 2)
 119           ELSE
 120             IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3)
 121           ENDIF
 122           REM  Loop round for tail-call optimisation.
 123         WHEN "fn*"
 124           =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%)
 125         WHEN "quote"
 126           =FNnth(ast%, 1)
 127         WHEN "quasiquote"
 128           ast% = FNquasiquote(FNnth(ast%, 1))
 129           REM  Loop round for tail-call optimisation
 130         OTHERWISE
 131           specialform% = FALSE
 132       ENDCASE
 133     ENDIF
 134     IF NOT specialform% THEN
 135       REM  This is the "apply" part.
 136       ast% = FNeval_ast(ast%, env%)
 137       car% = FNfirst(ast%)
 138       IF FNis_corefn(car%) THEN
 139         =FNcore_call(FNunbox_corefn(car%), FNrest(ast%))
 140       ENDIF
 141       IF FNis_fn(car%) THEN
 142         env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%))
 143         ast% = FNfn_ast(car%)
 144         REM  Loop round for tail-call optimisation.
 145       ELSE
 146         ERROR &40E80918, "Not a function"
 147       ENDIF
 148     ENDIF
 149   UNTIL FALSE
 150
 151 DEF FNPRINT(a%)
 152 =FNunbox_string(FNpr_str(a%, TRUE))
 153
 154 DEF FNrep(a$)
 155 =FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
 156
 157 DEF FNeval_ast(ast%, env%)
 158   LOCAL val%, car%, cdr%, map%, keys%, key$
 159   IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
 160   IF FNis_seq(ast%) THEN
 161     IF FNis_empty(ast%) THEN =ast%
 162     car% = FNEVAL(FNfirst(ast%), env%)
 163     cdr% = FNeval_ast(FNrest(ast%), env%)
 164     IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
 165     =FNalloc_pair(car%, cdr%)
 166   ENDIF
 167   IF FNis_hashmap(ast%) THEN
 168     map% = FNempty_hashmap
 169     keys% = FNhashmap_keys(ast%)
 170     WHILE NOT FNis_empty(keys%)
 171       key$ = FNunbox_string(FNfirst(keys%))
 172       map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
 173       keys% = FNrest(keys%)
 174     ENDWHILE
 175     =map%
 176   ENDIF
 177 =ast%
 178
 179 DEF FNget_argv
 180   PROCgc_enter
 181   LOCAL argv%, rargv%, cmdptr%, arg$, len%
 182   argv% = FNempty
 183   IF !PAGE = &D7C1C7C5 THEN
 184     REM  Running under Brandy, so ARGC and ARGV$ are usable.
 185     IF ARGC >= 1 THEN
 186       FOR i% = ARGC TO 1 STEP -1
 187         argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%)
 188       NEXT i%
 189     ENDIF
 190   ELSE
 191     IF (INKEY(-256) AND &F0) = &A0 THEN
 192       rargv% = FNempty
 193       REM  Running under RISC OS
 194       REM  Vexingly, we can only get the command line that was passed to
 195       REM  the BASIC interpreter.  This means that we need to extract
 196       REM  the arguments from that.  Typically, we will have been started
 197       REM  with "BASIC -quit <filename> <args>".
 198
 199       DIM q% 256
 200       SYS "OS_GetEnv" TO cmdptr%
 201       WHILE ?cmdptr% >= 32
 202         SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len%
 203         q%?len% = 13
 204         rargv% = FNalloc_pair(FNalloc_string($q%), rargv%)
 205       ENDWHILE
 206       REM  Put argv back into the right order.
 207       WHILE NOT FNis_empty(rargv%)
 208         argv% = FNalloc_pair(FNfirst(rargv%), argv%)
 209         rargv% = FNrest(rargv%)
 210       ENDWHILE
 211       IF FNis_empty(argv%) THEN =FNgc_exit(argv%)
 212       argv% = FNrest(argv%) : REM skip "BASIC"
 213       IF FNis_empty(argv%) THEN =FNgc_exit(argv%)
 214       IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%)
 215       argv% = FNrest(argv%) : REM skip "-quit"
 216       IF FNis_empty(argv%) THEN =FNgc_exit(argv%)
 217       argv% = FNrest(argv%) : REM skip filename
 218     ENDIF
 219   ENDIF
 220 =FNgc_exit(argv%)
 221
 222
 223 REM Local Variables:
 224 REM indent-tabs-mode: nil
 225 REM End: