logo/stepA_mal.lg

   1 load "../logo/readline.lg
   2 load "../logo/reader.lg
   3 load "../logo/printer.lg
   4 load "../logo/types.lg
   5 load "../logo/env.lg
   6 load "../logo/core.lg
   7
   8 to _read :str
   9 output read_str :str
  10 end
  11
  12 to pairp :obj
  13 output and sequentialp :obj ((_count :obj) > 0)
  14 end
  15
  16 to quasiquote :ast
  17 if not pairp :ast [output (mal_list symbol_new "quote :ast)]
  18 localmake "a0 nth :ast 0
  19 if symbolnamedp "unquote :a0 [output nth :ast 1]
  20 if pairp :a0 [
  21   localmake "a00 nth :a0 0
  22   if symbolnamedp "splice-unquote :a00 [
  23     localmake "a01 nth :a0 1
  24     output (mal_list symbol_new "concat :a01 (mal_list symbol_new "quasiquote rest :ast))
  25   ]
  26 ]
  27 output (mal_list symbol_new "cons (mal_list symbol_new "quasiquote :a0) (mal_list symbol_new "quasiquote rest :ast))
  28 end
  29
  30 to macrocallp :ast :env
  31 if (obj_type :ast) = "list [
  32   if (_count :ast) > 0 [
  33     localmake "a0 nth :ast 0
  34     if (obj_type :a0) = "symbol [
  35       if not emptyp env_find :env :a0 [
  36         localmake "f env_get :env :a0
  37         if (obj_type :f) = "fn [
  38           output fn_is_macro :f
  39         ]
  40       ]
  41     ]
  42   ]
  43 ]
  44 output "false
  45 end
  46
  47 to _macroexpand :ast :env
  48 if not macrocallp :ast :env [output :ast]
  49 localmake "a0 nth :ast 0
  50 localmake "f env_get :env :a0
  51 output _macroexpand invoke_fn :f rest :ast :env
  52 end
  53
  54 to eval_ast :ast :env
  55 output case (obj_type :ast) [
  56   [[symbol]  env_get :env :ast]
  57   [[list]    obj_new "list    map [_eval ? :env] obj_val :ast]
  58   [[vector]  obj_new "vector  map [_eval ? :env] obj_val :ast]
  59   [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast]
  60   [else :ast]
  61 ]
  62 end
  63
  64 to _eval :a_ast :a_env
  65 localmake "ast :a_ast
  66 localmake "env :a_env
  67 forever [
  68   if (obj_type :ast) <> "list [output eval_ast :ast :env]
  69   make "ast _macroexpand :ast :env
  70   if (obj_type :ast) <> "list [output eval_ast :ast :env]
  71   if emptyp obj_val :ast [output :ast]
  72   localmake "a0 nth :ast 0
  73   case list obj_type :a0 obj_val :a0 [
  74     [[[symbol def!]]
  75       localmake "a1 nth :ast 1
  76       localmake "a2 nth :ast 2
  77       output env_set :env :a1 _eval :a2 :env ]
  78
  79     [[[symbol let*]]
  80       localmake "a1 nth :ast 1
  81       localmake "letenv env_new :env [] []
  82       localmake "i 0
  83       while [:i < _count :a1] [
  84         ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv
  85         make "i (:i + 2)
  86       ]
  87       make "env :letenv
  88       make "ast nth :ast 2 ]        ; TCO
  89
  90     [[[symbol quote]]
  91       output nth :ast 1  ]
  92
  93     [[[symbol quasiquote]]
  94       make "ast quasiquote nth :ast 1 ]     ; TCO
  95
  96     [[[symbol defmacro!]]
  97       localmake "a1 nth :ast 1
  98       localmake "a2 nth :ast 2
  99       localmake "macro_fn _eval :a2 :env
 100       fn_set_macro :macro_fn
 101       output env_set :env :a1 :macro_fn ]
 102
 103     [[[symbol macroexpand]]
 104       output _macroexpand nth :ast 1 :env ]
 105
 106     [[[symbol try*]]
 107       localmake "result nil_new
 108       catch "error [make "result _eval nth :ast 1 :env]
 109       localmake "exception error
 110       ifelse or emptyp :exception ((_count :ast) < 3) [
 111         output :result
 112       ] [
 113         localmake "e first butfirst :exception
 114         localmake "exception_obj ifelse :e = "_mal_exception_ [:global_exception] [obj_new "string :e]
 115         localmake "a2 nth :ast 2
 116         localmake "catchenv env_new :env [] []
 117         ignore env_set :catchenv nth :a2 1 :exception_obj
 118         output _eval nth :a2 2 :catchenv
 119       ] ]
 120
 121     [[[symbol do]]
 122       localmake "i 1
 123       while [:i < ((_count :ast) - 1)] [
 124         ignore _eval nth :ast :i :env
 125         make "i (:i + 1)
 126       ]
 127       make "ast last obj_val :ast ] ; TCO
 128
 129     [[[symbol if]]
 130       localmake "a1 nth :ast 1
 131       localmake "cond _eval :a1 :env
 132       case obj_type :cond [
 133         [[nil false] ifelse (_count :ast) > 3 [
 134                        make "ast nth :ast 3  ; TCO
 135                      ] [
 136                        output nil_new
 137                      ]]
 138         [else        make "ast nth :ast 2]   ; TCO
 139       ]]
 140
 141     [[[symbol fn*]]
 142       output fn_new nth :ast 1 :env nth :ast 2 ]
 143
 144     [else
 145       localmake "el eval_ast :ast :env
 146       localmake "f nth :el 0
 147       case obj_type :f [
 148         [[nativefn]
 149           output apply obj_val :f butfirst obj_val :el ]
 150         [[fn]
 151           make "env env_new fn_env :f fn_args :f rest :el
 152           make "ast fn_body :f ]  ; TCO
 153         [else
 154           (throw "error [Wrong type for apply])]
 155       ] ]
 156   ]
 157 ]
 158 end
 159
 160 to _print :exp
 161 output pr_str :exp "true
 162 end
 163
 164 to re :str
 165 output _eval _read :str :repl_env
 166 end
 167
 168 to rep :str
 169 output _print re :str
 170 end
 171
 172 to print_exception :exception
 173 if not emptyp :exception [
 174   localmake "e first butfirst :exception
 175   ifelse :e = "_mal_exception_ [
 176     (print "Error: pr_str :global_exception "false)
 177   ] [
 178     (print "Error: :e)
 179   ]
 180 ]
 181 end
 182
 183 to repl
 184 localmake "running "true
 185 while [:running] [
 186   localmake "line readline word "user> :space_char
 187   ifelse :line=[] [
 188     print "
 189     make "running "false
 190   ] [
 191     if not emptyp :line [
 192       catch "error [print rep :line]
 193       print_exception error
 194     ]
 195   ]
 196 ]
 197 end
 198
 199 to mal_eval :a
 200 output _eval :a :repl_env
 201 end
 202
 203 to argv_list
 204 localmake "argv ifelse emptyp :command.line [[]] [butfirst :command.line]
 205 output obj_new "list map [obj_new "string ?] :argv
 206 end
 207
 208 make "repl_env env_new [] [] []
 209 foreach :core_ns [
 210   ignore env_set :repl_env first ? first butfirst ?
 211 ]
 212 ignore env_set :repl_env [symbol eval] [nativefn mal_eval]
 213 ignore env_set :repl_env [symbol *ARGV*] argv_list
 214
 215 ; core.mal: defined using the language itself
 216 ignore re "|(def! *host-language* "logo")|
 217 ignore re "|(def! not (fn* (a) (if a false true)))|
 218 ignore re "|(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))|
 219 ignore re "|(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)))))))|
 220 ignore re "|(def! *gensym-counter* (atom 0))|
 221 ignore re "|(def! gensym (fn* [] (symbol (str "G__" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))|
 222 ignore re "|(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)))))))))|
 223
 224 if not emptyp :command.line [
 225   catch "error [ignore re (word "\(load-file :space_char "\" first :command.line "\"\) )]
 226   print_exception error
 227   bye
 228 ]
 229
 230 ignore re "|(println (str "Mal [" *host-language* "]"))|
 231 repl
 232 bye