impls/elisp/stepA_mal.el

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