bbc-basic/step6_file.bbc

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