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