elisp/stepA_mal.el

   1 ;; -*- lexical-binding: t; -*-
   2
   3 (defun load-relative (file)
   4   (let* ((current-file (or load-file-name buffer-file-name))
   5          (current-file-directory (file-name-directory current-file)))
   6     (load (expand-file-name file current-file-directory) nil t)))
   7
   8 (load-relative "types.el")
   9 (load-relative "env.el")
  10 (load-relative "func.el")
  11 (load-relative "reader.el")
  12 (load-relative "printer.el")
  13 (load-relative "core.el")
  14
  15 (defvar repl-env (mal-env))
  16
  17 (dolist (binding core-ns)
  18   (let ((symbol (car binding))
  19         (fn (cdr binding)))
  20     (mal-env-set repl-env symbol fn)))
  21
  22 (defun mal-pair-p (mal-object)
  23   (let ((type (mal-type mal-object))
  24         (value (mal-value mal-object)))
  25     (if (and (or (eq type 'list) (eq type 'vector))
  26              (not (zerop (length value))))
  27         t
  28       nil)))
  29
  30 (defun quasiquote (ast)
  31   (if (not (mal-pair-p ast))
  32       (mal-list (list (mal-symbol 'quote) ast))
  33     (let* ((a (mal-listify ast))
  34            (a0 (car a))
  35            (a0... (cdr a))
  36            (a1 (cadr a)))
  37       (cond
  38        ((eq (mal-value a0) 'unquote)
  39         a1)
  40        ((and (mal-pair-p a0)
  41              (eq (mal-value (car (mal-value a0)))
  42                  'splice-unquote))
  43         (mal-list (list (mal-symbol 'concat)
  44                         (cadr (mal-value a0))
  45                         (quasiquote (mal-list a0...)))))
  46        (t
  47         (mal-list (list (mal-symbol 'cons)
  48                         (quasiquote a0)
  49                         (quasiquote (mal-list a0...)))))))))
  50
  51 (defun macro-call-p (ast env)
  52   (when (mal-list-p ast)
  53     (let ((a0 (car (mal-value ast))))
  54       (when (mal-symbol-p a0)
  55         (let ((value (mal-env-find env (mal-value a0))))
  56           (when (and (mal-func-p value)
  57                      (mal-func-macro-p value))
  58             t))))))
  59
  60 (defun MACROEXPAND (ast env)
  61   (while (macro-call-p ast env)
  62     (let* ((a (mal-value ast))
  63            (a0* (mal-value (car a)))
  64            (a0... (cdr a))
  65            (macro (mal-env-find env a0*)))
  66       (setq ast (apply (mal-value (mal-func-fn macro)) a0...))))
  67   ast)
  68
  69 (defun READ (input)
  70   (read-str input))
  71
  72 (defun EVAL (ast env)
  73   (catch 'return
  74     (while t
  75       (when (not (mal-list-p ast))
  76         (throw 'return (eval-ast ast env)))
  77
  78       (setq ast (MACROEXPAND ast env))
  79       (when (or (not (mal-list-p ast)) (not (mal-value ast)))
  80         (throw 'return (eval-ast ast env)))
  81
  82       (let* ((a (mal-value ast))
  83              (a0 (car a))
  84              (a0* (mal-value a0))
  85              (a1 (cadr a))
  86              (a2 (nth 2 a))
  87              (a3 (nth 3 a)))
  88         (cond
  89          ((eq a0* 'def!)
  90           (let* ((identifier (mal-value a1))
  91                  (value (EVAL a2 env)))
  92             (throw 'return (mal-env-set env identifier value))))
  93          ((eq a0* 'let*)
  94           (let* ((env* (mal-env env))
  95                  (bindings (mal-value a1))
  96                  (form a2))
  97             (when (vectorp bindings)
  98               (setq bindings (append bindings nil)))
  99             (while bindings
 100               (let ((key (mal-value (pop bindings)))
 101                     (value (EVAL (pop bindings) env*)))
 102                 (mal-env-set env* key value)))
 103             (setq env env*
 104                   ast form))) ; TCO
 105          ((eq a0* 'quote)
 106           (throw 'return a1))
 107          ((eq a0* 'quasiquote)
 108           (setq ast (quasiquote a1))) ; TCO
 109          ((eq a0* 'defmacro!)
 110           (let ((identifier (mal-value a1))
 111                 (value (EVAL a2 env)))
 112             (setf (aref (aref value 1) 4) t)
 113             (throw 'return (mal-env-set env identifier value))))
 114          ((eq a0* 'macroexpand)
 115           (throw 'return (MACROEXPAND a1 env)))
 116          ((eq a0* 'try*)
 117           (condition-case err
 118               (throw 'return (EVAL a1 env))
 119             (error
 120              (if (and a2 (eq (mal-value (car (mal-value a2))) 'catch*))
 121                  (let* ((a2* (mal-value a2))
 122                         (identifier (mal-value (cadr a2*)))
 123                         (form (nth 2 a2*))
 124                         (err* (if (eq (car err) 'mal-custom)
 125                                   ;; throw
 126                                   (cadr err)
 127                                 ;; normal error
 128                                 (mal-string (error-message-string err))))
 129                         (env* (mal-env env (list identifier) (list err*))))
 130                    (throw 'return (EVAL form env*)))
 131                (apply 'signal err)))))
 132          ((eq a0* 'do)
 133           (let* ((a0... (cdr a))
 134                  (butlast (butlast a0...))
 135                  (last (car (last a0...))))
 136             (when butlast
 137               (eval-ast (mal-list butlast) env))
 138             (setq ast last))) ; TCO
 139          ((eq a0* 'if)
 140           (let* ((condition (EVAL a1 env))
 141                  (condition-type (mal-type condition))
 142                  (then a2)
 143                  (else a3))
 144             (if (and (not (eq condition-type 'false))
 145                      (not (eq condition-type 'nil)))
 146                 (setq ast then) ; TCO
 147               (if else
 148                   (setq ast else) ; TCO
 149                 (throw 'return mal-nil)))))
 150          ((eq a0* 'fn*)
 151           (let* ((binds (mapcar 'mal-value (mal-value a1)))
 152                  (body a2)
 153                  (fn (mal-fn
 154                       (lambda (&rest args)
 155                         (let ((env* (mal-env env binds args)))
 156                           (EVAL body env*))))))
 157             (throw 'return (mal-func body binds env fn))))
 158          (t
 159           ;; not a special form
 160           (let* ((ast* (mal-value (eval-ast ast env)))
 161                  (fn (car ast*))
 162                  (args (cdr ast*)))
 163             (if (mal-func-p fn)
 164                 (let ((env* (mal-env (mal-func-env fn)
 165                                      (mal-func-params fn)
 166                                      args)))
 167                   (setq env env*
 168                         ast (mal-func-ast fn))) ; TCO
 169               ;; built-in function
 170               (let ((fn* (mal-value fn)))
 171                 (throw 'return (apply fn* args)))))))))))
 172
 173 (defun eval-ast (ast env)
 174   (let ((type (mal-type ast))
 175         (value (mal-value ast)))
 176     (cond
 177      ((eq type 'symbol)
 178       (let ((definition (mal-env-get env value)))
 179         (or definition (error "Definition not found"))))
 180      ((eq type 'list)
 181       (mal-list (mapcar (lambda (item) (EVAL item env)) value)))
 182      ((eq type 'vector)
 183       (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value))))
 184      ((eq type 'map)
 185       (let ((map (copy-hash-table value)))
 186         (maphash (lambda (key value)
 187                    (puthash key (EVAL value env) map))
 188                  map)
 189         (mal-map map)))
 190      (t
 191       ;; return as is
 192       ast))))
 193
 194 (mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env)))))
 195 (mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv))))
 196 (mal-env-set repl-env '*host-language* (mal-string "elisp"))
 197
 198 (defun PRINT (input)
 199   (pr-str input t))
 200
 201 (defun rep (input)
 202   (PRINT (EVAL (READ input) repl-env)))
 203
 204 (rep "(def! not (fn* (a) (if a false true)))")
 205 (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
 206
 207 (rep "(def! *gensym-counter* (atom 0))")
 208 (rep "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))")
 209
 210 (rep "(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)))))))")
 211 (rep "(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)))))))))")
 212
 213 (defun readln (prompt)
 214   ;; C-d throws an error
 215   (ignore-errors (read-from-minibuffer prompt)))
 216
 217 (defun println (format-string &rest args)
 218   (if (not args)
 219       (princ format-string)
 220     (princ (apply 'format format-string args)))
 221   (terpri))
 222
 223 (defmacro with-error-handling (&rest body)
 224   `(condition-case err
 225        (progn ,@body)
 226      (end-of-token-stream
 227       ;; empty input, carry on
 228       )
 229      (unterminated-sequence
 230       (let* ((type (cadr err))
 231              (end
 232               (cond
 233                ((eq type 'string) ?\")
 234                ((eq type 'list) ?\))
 235                ((eq type 'vector) ?\])
 236                ((eq type 'map) ?}))))
 237         (princ (format "Expected '%c', got EOF\n" end))))
 238      (error ; catch-all
 239       (println (error-message-string err)))))
 240
 241 (defun main ()
 242   (if argv
 243       (with-error-handling
 244        (rep (format "(load-file \"%s\")" (car argv))))
 245     (let (eof)
 246       (rep "(println (str \"Mal [\" *host-language* \"]\"))")
 247       (while (not eof)
 248         (let ((input (readln "user> ")))
 249           (if input
 250               (with-error-handling
 251                (println (rep input)))
 252             (setq eof t)
 253             ;; print final newline
 254             (terpri)))))))
 255
 256 (main)