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