bbc-basic/step6_file.bas

   1 REM Step 6 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 FNEVAL(ast%, env%)
  57   PROCgc_enter
  58 =FNgc_exit(FNEVAL_(ast%, env%))
  59
  60 DEF FNEVAL_(ast%, env%)
  61   LOCAL car%, specialform%, val%, bindings%
  62   REPEAT
  63     PROCgc_keep_only2(ast%, env%)
  64     IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
  65     IF FNis_empty(ast%) THEN =ast%
  66     car% = FNfirst(ast%)
  67     specialform% = FALSE
  68     IF FNis_symbol(car%) THEN
  69       specialform% = TRUE
  70       CASE FNunbox_symbol(car%) OF
  71         REM  Special forms
  72         WHEN "def!"
  73           val% = FNEVAL(FNnth(ast%, 2), env%)
  74           PROCenv_set(env%, FNnth(ast%, 1), val%)
  75           =val%
  76         WHEN "let*"
  77           env% = FNalloc_environment(env%)
  78           bindings% = FNnth(ast%, 1)
  79           WHILE NOT FNis_empty(bindings%)
  80             PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%))
  81             bindings% = FNrest(FNrest(bindings%))
  82           ENDWHILE
  83           ast% = FNnth(ast%, 2)
  84           REM  Loop round for tail-call optimisation.
  85         WHEN "do"
  86           REM  The guide has us call FNeval_ast on the sub-list that excludes
  87           REM  the last element of ast%, but that's a bit painful without
  88           REM  native list slicing, so it's easier to just re-implement the
  89           REM  bit of FNeval_ast that we need.
  90           ast% = FNrest(ast%)
  91           WHILE NOT FNis_empty(FNrest(ast%))
  92             val% = FNEVAL(FNfirst(ast%), env%)
  93             ast% = FNrest(ast%)
  94           ENDWHILE
  95           ast% = FNfirst(ast%)
  96         WHEN "if"
  97           IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN
  98             ast% = FNnth(ast%, 2)
  99           ELSE
 100             IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3)
 101           ENDIF
 102           REM  Loop round for tail-call optimisation.
 103         WHEN "fn*"
 104           =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%)
 105         OTHERWISE
 106           specialform% = FALSE
 107       ENDCASE
 108     ENDIF
 109     IF NOT specialform% THEN
 110       REM  This is the "apply" part.
 111       ast% = FNeval_ast(ast%, env%)
 112       car% = FNfirst(ast%)
 113       IF FNis_corefn(car%) THEN
 114         =FNcore_call(FNunbox_corefn(car%), FNrest(ast%))
 115       ENDIF
 116       IF FNis_fn(car%) THEN
 117         env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%))
 118         ast% = FNfn_ast(car%)
 119         REM  Loop round for tail-call optimisation.
 120       ELSE
 121         ERROR &40E80918, "Not a function"
 122       ENDIF
 123     ENDIF
 124   UNTIL FALSE
 125
 126 DEF FNPRINT(a%)
 127 =FNunbox_string(FNpr_str(a%, TRUE))
 128
 129 DEF FNrep(a$)
 130 =FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
 131
 132 DEF FNeval_ast(ast%, env%)
 133   LOCAL val%, car%, cdr%, map%, keys%, key$
 134   IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
 135   IF FNis_seq(ast%) THEN
 136     IF FNis_empty(ast%) THEN =ast%
 137     car% = FNEVAL(FNfirst(ast%), env%)
 138     cdr% = FNeval_ast(FNrest(ast%), env%)
 139     IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
 140     =FNalloc_pair(car%, cdr%)
 141   ENDIF
 142   IF FNis_hashmap(ast%) THEN
 143     map% = FNempty_hashmap
 144     keys% = FNhashmap_keys(ast%)
 145     WHILE NOT FNis_empty(keys%)
 146       key$ = FNunbox_string(FNfirst(keys%))
 147       map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
 148       keys% = FNrest(keys%)
 149     ENDWHILE
 150     =map%
 151   ENDIF
 152 =ast%
 153
 154 DEF FNget_argv
 155   PROCgc_enter
 156   LOCAL argv%, rargv%, cmdptr%, arg$, len%
 157   argv% = FNempty
 158   IF !PAGE = &D7C1C7C5 THEN
 159     REM  Running under Brandy, so ARGC and ARGV$ are usable.
 160     IF ARGC >= 1 THEN
 161       FOR i% = ARGC TO 1 STEP -1
 162         argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%)
 163       NEXT i%
 164     ENDIF
 165   ELSE
 166     IF (INKEY(-256) AND &F0) = &A0 THEN
 167       rargv% = FNempty
 168       REM  Running under RISC OS
 169       REM  Vexingly, we can only get the command line that was passed to
 170       REM  the BASIC interpreter.  This means that we need to extract
 171       REM  the arguments from that.  Typically, we will have been started
 172       REM  with "BASIC -quit <filename> <args>".
 173
 174       DIM q% 256
 175       SYS "OS_GetEnv" TO cmdptr%
 176       WHILE ?cmdptr% >= 32
 177         SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len%
 178         q%?len% = 13
 179         rargv% = FNalloc_pair(FNalloc_string($q%), rargv%)
 180       ENDWHILE
 181       REM  Put argv back into the right order.
 182       WHILE NOT FNis_empty(rargv%)
 183         argv% = FNalloc_pair(FNfirst(rargv%), argv%)
 184         rargv% = FNrest(rargv%)
 185       ENDWHILE
 186       IF FNis_empty(argv%) THEN =FNgc_exit(argv%)
 187       argv% = FNrest(argv%) : REM skip "BASIC"
 188       IF FNis_empty(argv%) THEN =FNgc_exit(argv%)
 189       IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%)
 190       argv% = FNrest(argv%) : REM skip "-quit"
 191       IF FNis_empty(argv%) THEN =FNgc_exit(argv%)
 192       argv% = FNrest(argv%) : REM skip filename
 193     ENDIF
 194   ENDIF
 195 =FNgc_exit(argv%)
 196
 197
 198 REM Local Variables:
 199 REM indent-tabs-mode: nil
 200 REM End: