bbc-basic/step9_try.bbc

   1 REM Step 9 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 (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw "odd number of forms to cond")) (cons 'cond (rest (rest xs)))))))
  25 DATA (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))
  26 DATA ""
  27 REPEAT
  28   READ form$
  29   IF form$ <> "" THEN val$ = FNrep(form$)
  30 UNTIL form$ = ""
  31
  32 argv% = FNget_argv
  33
  34 IF FNis_empty(argv%) THEN
  35   PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty)
  36 ELSE
  37   PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%))
  38   val$ = FNrep("(load-file " + FNpr_str(FNfirst(argv%), TRUE) + ")")
  39   END
  40 ENDIF
  41
  42 REPEAT
  43   REM  Catch all errors apart from "Escape".
  44   ON ERROR LOCAL PRINT REPORT$:IF ERR = 17 THEN END ELSE PROCgc_restore(sav%)
  45   sav% = FNgc_save
  46   PRINT "user> ";
  47   LINE INPUT "" line$
  48   PRINT FNrep(line$)
  49   PROCgc_restore(sav%)
  50 UNTIL FALSE
  51
  52 END
  53
  54 DEF FNREAD(a$)
  55 =FNread_str(a$)
  56
  57 DEF FNis_pair(val%)
  58 =FNis_seq(val%) AND NOT FNis_empty(val%)
  59
  60 DEF FNquasiquote(ast%)
  61   LOCAL car%, caar%
  62   IF NOT FNis_pair(ast%) THEN =FNalloc_list2(FNalloc_symbol("quote"), ast%)
  63   car% = FNfirst(ast%)
  64   IF FNis_symbol(car%) THEN
  65     IF FNunbox_symbol(car%) = "unquote" THEN =FNnth(ast%, 1)
  66   ENDIF
  67   IF FNis_pair(car%) THEN
  68     caar% = FNfirst(car%)
  69     IF FNis_symbol(caar%) THEN
  70       IF FNunbox_symbol(caar%) = "splice-unquote" THEN
  71         =FNalloc_list3(FNalloc_symbol("concat"), FNnth(car%, 1), FNquasiquote(FNrest(ast%)))
  72       ENDIF
  73     ENDIF
  74   ENDIF
  75 =FNalloc_list3(FNalloc_symbol("cons"), FNquasiquote(car%), FNquasiquote(FNrest(ast%)))
  76
  77 DEF FNis_macro_call(ast%, env%)
  78   LOCAL car%, val%
  79   IF NOT FNis_list(ast%) THEN =FALSE
  80   car% = FNfirst(ast%)
  81   IF NOT FNis_symbol(car%) THEN =FALSE
  82   IF FNis_nil(FNenv_find(env%, car%)) THEN =FALSE
  83   val% = FNenv_get(env%, car%)
  84 =FNis_macro(val%)
  85
  86 DEF FNmacroexpand(ast%, env%)
  87   LOCAL mac%, macenv%, macast%
  88   WHILE FNis_macro_call(ast%, env%)
  89     REM PRINT "expanded ";FNpr_str(ast%, TRUE);
  90     mac% = FNenv_get(env%, FNfirst(ast%))
  91     macenv% = FNnew_env(FNfn_env(mac%), FNfn_params(mac%), FNrest(ast%))
  92     macast% = FNfn_ast(mac%)
  93     ast% = FNEVAL(macast%, macenv%)
  94     REM PRINT " to ";FNpr_str(ast%, TRUE)
  95   ENDWHILE
  96 =ast%
  97
  98 DEF FNtry_catch(ast%, env%)
  99   LOCAL is_error%, ret%
 100   REM  If there's no 'catch*' clause then we just evaluate the 'try*'.
 101   IF FNcount(ast%) < 3 THEN =FNEVAL(FNnth(ast%, 1), env%)
 102   IF FNunbox_symbol(FNfirst(FNnth(ast%, 2))) <> "catch*" THEN
 103     ERROR &40E80924, "Invalid 'catch*' clause"
 104   ENDIF
 105   ret% = FNtry(FNnth(ast%, 1), env%, is_error%)
 106   IF is_error% THEN =FNcatch(FNnth(ast%, 2), env%, ret%)
 107 =ret%
 108
 109 REM  Evaluate an expression, returning either the result or an exception
 110 REM  raised during evaluation.  is_error% indicates which it was.
 111 DEF FNtry(ast%, env%, RETURN is_error%)
 112   LOCAL trysav%
 113   trysav% = FNgc_save
 114   is_error% = FALSE
 115   LOCAL ERROR
 116   ON ERROR LOCAL is_error% = TRUE : =FNgc_restore(trysav%, FNwrap_exception)
 117 =FNgc_restore(trysav%, FNEVAL(ast%, env%))
 118
 119 REM  Return a mal value corresponding to the most-recently thrown exception.
 120 DEF FNwrap_exception
 121   IF ERR = &40E80900 THEN =MAL_ERR% : REM  Error generated by 'throw'
 122 =FNalloc_string(REPORT$)            : REM  OS error or error generated by mal
 123
 124 DEF FNcatch(ast%, env%, err%)
 125   LOCAL binds%, exprs%
 126   binds% = FNalloc_pair(FNnth(ast%, 1), FNempty)
 127   exprs% = FNalloc_pair(err%, FNempty)
 128   env% = FNnew_env(env%, binds%, exprs%)
 129 =FNEVAL(FNnth(ast%, 2), env%)
 130
 131 DEF FNEVAL(ast%, env%)
 132   PROCgc_enter
 133 =FNgc_exit(FNEVAL_(ast%, env%))
 134
 135 DEF FNEVAL_(ast%, env%)
 136   LOCAL car%, specialform%, val%, bindings%
 137   REPEAT
 138     PROCgc_keep_only2(ast%, env%)
 139     IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
 140     IF FNis_empty(ast%) THEN =ast%
 141     ast% = FNmacroexpand(ast%, env%)
 142     IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
 143     car% = FNfirst(ast%)
 144     specialform% = FALSE
 145     IF FNis_symbol(car%) THEN
 146       specialform% = TRUE
 147       CASE FNunbox_symbol(car%) OF
 148         REM  Special forms
 149         WHEN "def!"
 150           val% = FNEVAL(FNnth(ast%, 2), env%)
 151           PROCenv_set(env%, FNnth(ast%, 1), val%)
 152           =val%
 153         WHEN "defmacro!"
 154           val% = FNEVAL(FNnth(ast%, 2), env%)
 155           IF FNis_fn(val%) THEN PROCmake_macro(val%)
 156           PROCenv_set(env%, FNnth(ast%, 1), val%)
 157           =val%
 158         WHEN "let*"
 159           env% = FNalloc_environment(env%)
 160           bindings% = FNnth(ast%, 1)
 161           WHILE NOT FNis_empty(bindings%)
 162             PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%))
 163             bindings% = FNrest(FNrest(bindings%))
 164           ENDWHILE
 165           ast% = FNnth(ast%, 2)
 166           REM  Loop round for tail-call optimisation.
 167         WHEN "do"
 168           REM  The guide has us call FNeval_ast on the sub-list that excludes
 169           REM  the last element of ast%, but that's a bit painful without
 170           REM  native list slicing, so it's easier to just re-implement the
 171           REM  bit of FNeval_ast that we need.
 172           ast% = FNrest(ast%)
 173           WHILE NOT FNis_empty(FNrest(ast%))
 174             val% = FNEVAL(FNfirst(ast%), env%)
 175             ast% = FNrest(ast%)
 176           ENDWHILE
 177           ast% = FNfirst(ast%)
 178         WHEN "if"
 179           IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN
 180             ast% = FNnth(ast%, 2)
 181           ELSE
 182             IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3)
 183           ENDIF
 184           REM  Loop round for tail-call optimisation.
 185         WHEN "fn*"
 186           =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%)
 187         WHEN "quote"
 188           =FNnth(ast%, 1)
 189         WHEN "quasiquote"
 190           ast% = FNquasiquote(FNnth(ast%, 1))
 191           REM  Loop round for tail-call optimisation
 192         WHEN "macroexpand"
 193           =FNmacroexpand(FNnth(ast%, 1), env%)
 194         WHEN "try*"
 195           =FNtry_catch(ast%, env%)
 196         OTHERWISE
 197           specialform% = FALSE
 198       ENDCASE
 199     ENDIF
 200     IF NOT specialform% THEN
 201       REM  This is the "apply" part.
 202       ast% = FNeval_ast(ast%, env%)
 203       car% = FNfirst(ast%)
 204       IF FNis_corefn(car%) THEN
 205         =FNcore_call(FNunbox_corefn(car%), FNrest(ast%))
 206       ENDIF
 207       IF FNis_fn(car%) THEN
 208         env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%))
 209         ast% = FNfn_ast(car%)
 210         REM  Loop round for tail-call optimisation.
 211       ELSE
 212         ERROR &40E80918, "Not a function"
 213       ENDIF
 214     ENDIF
 215   UNTIL FALSE
 216
 217 DEF FNPRINT(a%)
 218 =FNpr_str(a%, TRUE)
 219
 220 DEF FNrep(a$)
 221 =FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
 222
 223 DEF FNeval_ast(ast%, env%)
 224   LOCAL val%, car%, cdr%
 225   IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
 226   IF FNis_seq(ast%) THEN
 227     IF FNis_empty(ast%) THEN =ast%
 228     car% = FNEVAL(FNfirst(ast%), env%)
 229     cdr% = FNeval_ast(FNrest(ast%), env%)
 230     IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
 231     =FNalloc_pair(car%, cdr%)
 232   ENDIF
 233 =ast%
 234
 235 DEF FNget_argv
 236   PROCgc_enter
 237   LOCAL argv%, rargv%, cmdptr%, arg$, len%
 238   argv% = FNempty
 239   IF !PAGE = &D7C1C7C5 THEN
 240     REM  Running under Brandy, so ARGC and ARGV$ are usable.
 241     IF ARGC >= 1 THEN
 242       FOR i% = ARGC TO 1 STEP -1
 243         argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%)
 244       NEXT i%
 245     ENDIF
 246   ELSE
 247     IF (INKEY(-256) AND &F0) = &A0 THEN
 248       rargv% = FNempty
 249       REM  Running under RISC OS
 250       REM  Vexingly, we can only get the command line that was passed to
 251       REM  the BASIC interpreter.  This means that we need to extract
 252       REM  the arguments from that.  Typically, we will have been started
 253       REM  with "BASIC -quit <filename> <args>".
 254
 255       DIM q% 256
 256       SYS "OS_GetEnv" TO cmdptr%
 257       WHILE ?cmdptr% >= 32
 258         SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len%
 259         q%?len% = 13
 260         rargv% = FNalloc_pair(FNalloc_string($q%), rargv%)
 261       ENDWHILE
 262       REM  Put argv back into the right order.
 263       WHILE NOT FNis_empty(rargv%)
 264         argv% = FNalloc_pair(FNfirst(rargv%), argv%)
 265         rargv% = FNrest(rargv%)
 266       ENDWHILE
 267       IF FNis_empty(argv%) THEN =FNgc_exit(argv%)
 268       argv% = FNrest(argv%) : REM skip "BASIC"
 269       IF FNis_empty(argv%) THEN =FNgc_exit(argv%)
 270       IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%)
 271       argv% = FNrest(argv%) : REM skip "-quit"
 272       IF FNis_empty(argv%) THEN =FNgc_exit(argv%)
 273       argv% = FNrest(argv%) : REM skip filename
 274     ENDIF
 275   ENDIF
 276 =FNgc_exit(argv%)
 277
 278
 279 REM Local Variables:
 280 REM indent-tabs-mode: nil
 281 REM End: