bbc-basic/stepA_mal.bbc

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