Merge pull request #378 from asarhaddon/test-macro-not-changing-function

[jackhill/mal.git] / logo / stepA_mal.lg

load "../logo/readline.lg
load "../logo/reader.lg
load "../logo/printer.lg
load "../logo/types.lg
load "../logo/env.lg
load "../logo/core.lg

to _read :str
output read_str :str
end

to pairp :obj
output and sequentialp :obj ((_count :obj) > 0)
end

to quasiquote :ast
if not pairp :ast [output (mal_list symbol_new "quote :ast)]
localmake "a0 nth :ast 0
if symbolnamedp "unquote :a0 [output nth :ast 1]
if pairp :a0 [
  localmake "a00 nth :a0 0
  if symbolnamedp "splice-unquote :a00 [
    localmake "a01 nth :a0 1
    output (mal_list symbol_new "concat :a01 (mal_list symbol_new "quasiquote rest :ast))
  ]
]
output (mal_list symbol_new "cons (mal_list symbol_new "quasiquote :a0) (mal_list symbol_new "quasiquote rest :ast))
end

to macrocallp :ast :env
if (obj_type :ast) = "list [
  if (_count :ast) > 0 [
    localmake "a0 nth :ast 0
    if (obj_type :a0) = "symbol [
      if not emptyp env_find :env :a0 [
        localmake "f env_get :env :a0
        if (obj_type :f) = "fn [
          output fn_is_macro :f
        ]
      ]
    ]
  ]
]
output "false
end

to _macroexpand :ast :env
if not macrocallp :ast :env [output :ast]
localmake "a0 nth :ast 0
localmake "f env_get :env :a0
output _macroexpand invoke_fn :f rest :ast :env
end

to eval_ast :ast :env
output case (obj_type :ast) [
  [[symbol]  env_get :env :ast]
  [[list]    obj_new "list    map [_eval ? :env] obj_val :ast]
  [[vector]  obj_new "vector  map [_eval ? :env] obj_val :ast]
  [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast]
  [else :ast]
]
end

to _eval :a_ast :a_env
localmake "ast :a_ast
localmake "env :a_env
forever [
  if (obj_type :ast) <> "list [output eval_ast :ast :env]
  make "ast _macroexpand :ast :env
  if (obj_type :ast) <> "list [output eval_ast :ast :env]
  if emptyp obj_val :ast [output :ast]
  localmake "a0 nth :ast 0
  case list obj_type :a0 obj_val :a0 [
    [[[symbol def!]]
      localmake "a1 nth :ast 1
      localmake "a2 nth :ast 2
      output env_set :env :a1 _eval :a2 :env ]

    [[[symbol let*]]
      localmake "a1 nth :ast 1
      localmake "letenv env_new :env [] []
      localmake "i 0
      while [:i < _count :a1] [
        ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv
        make "i (:i + 2)
      ]
      make "env :letenv
      make "ast nth :ast 2 ]        ; TCO

    [[[symbol quote]]
      output nth :ast 1  ]

    [[[symbol quasiquote]]
      make "ast quasiquote nth :ast 1 ]     ; TCO

    [[[symbol defmacro!]]
      localmake "a1 nth :ast 1
      localmake "a2 nth :ast 2
      localmake "macro_fn _eval :a2 :env
      fn_set_macro :macro_fn
      output env_set :env :a1 :macro_fn ]

    [[[symbol macroexpand]]
      output _macroexpand nth :ast 1 :env ]

    [[[symbol try*]]
      localmake "a1 nth :ast 1
      if (_count :ast) < 3 [
        output _eval :a1 :env
      ]
      localmake "result nil_new
      catch "error [make "result _eval :a1 :env]
      localmake "exception error
      ifelse emptyp :exception [
        output :result
      ] [
        localmake "e first butfirst :exception
	localmake "exception_obj ifelse :e = "_mal_exception_ [:global_exception] [obj_new "string :e]
        localmake "a2 nth :ast 2
        localmake "catchenv env_new :env [] []
        ignore env_set :catchenv nth :a2 1 :exception_obj
        output _eval nth :a2 2 :catchenv
      ] ]

    [[[symbol do]]
      localmake "i 1
      while [:i < ((_count :ast) - 1)] [
        ignore _eval nth :ast :i :env
        make "i (:i + 1)
      ]
      make "ast last obj_val :ast ] ; TCO

    [[[symbol if]]
      localmake "a1 nth :ast 1
      localmake "cond _eval :a1 :env
      case obj_type :cond [
        [[nil false] ifelse (_count :ast) > 3 [
                       make "ast nth :ast 3  ; TCO
                     ] [
                       output nil_new
                     ]]
        [else        make "ast nth :ast 2]   ; TCO
      ]]

    [[[symbol fn*]]
      output fn_new nth :ast 1 :env nth :ast 2 ]

    [else
      localmake "el eval_ast :ast :env
      localmake "f nth :el 0
      case obj_type :f [
        [[nativefn]
          output apply obj_val :f butfirst obj_val :el ]
        [[fn]
          make "env env_new fn_env :f fn_args :f rest :el
          make "ast fn_body :f ]  ; TCO
        [else
          (throw "error [Wrong type for apply])]
      ] ]
  ]
]
end

to _print :exp
output pr_str :exp "true
end

to re :str
output _eval _read :str :repl_env
end

to rep :str
output _print re :str
end

to print_exception :exception
if not emptyp :exception [
  localmake "e first butfirst :exception
  ifelse :e = "_mal_exception_ [
    (print "Error: pr_str :global_exception "false)
  ] [
    (print "Error: :e)
  ]
]
end

to repl
localmake "running "true
while [:running] [
  localmake "line readline word "user> :space_char
  ifelse :line=[] [
    print "
    make "running "false
  ] [
    if not emptyp :line [
      catch "error [print rep :line]
      print_exception error
    ]
  ]
]
end

to mal_eval :a
output _eval :a :repl_env
end

to argv_list
localmake "argv ifelse emptyp :command.line [[]] [butfirst :command.line]
output obj_new "list map [obj_new "string ?] :argv
end

make "repl_env env_new [] [] []
foreach :core_ns [
  ignore env_set :repl_env first ? first butfirst ?
]
ignore env_set :repl_env [symbol eval] [nativefn mal_eval]
ignore env_set :repl_env [symbol *ARGV*] argv_list

; core.mal: defined using the language itself
ignore re "|(def! *host-language* "logo")|
ignore re "|(def! not (fn* (a) (if a false true)))|
ignore re "|(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))|
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)))))))|
ignore re "|(def! inc (fn* [x] (+ x 1)))|
ignore re "|(def! gensym (let* [counter (atom 0)] (fn* [] (symbol (str "G__" (swap! counter inc))))))|
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)))))))))|

if not emptyp :command.line [
  catch "error [ignore re (word "\(load-file :space_char "\" first :command.line "\"\) )]
  print_exception error
  bye
]

ignore re "|(println (str "Mal [" *host-language* "]"))|
repl
bye