elisp/step7_quote.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-value (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 READ (input)
  52   (read-str input))
  53
  54 (defun EVAL (ast env)
  55   (catch 'return
  56     (while t
  57       (if (mal-list-p ast)
  58           (let* ((a (mal-value ast))
  59                  (a0 (car a))
  60                  (a0* (mal-value a0))
  61                  (a1 (cadr a))
  62                  (a2 (nth 2 a))
  63                  (a3 (nth 3 a)))
  64             (cond
  65              ((eq a0* 'def!)
  66               (let ((identifier (mal-value a1))
  67                     (value (EVAL a2 env)))
  68                 (throw 'return (mal-env-set env identifier value))))
  69              ((eq a0* 'let*)
  70               (let* ((env* (mal-env env))
  71                      (bindings (mal-value a1))
  72                      (form a2))
  73                 (when (vectorp bindings)
  74                   (setq bindings (append bindings nil)))
  75                 (while bindings
  76                   (let ((key (mal-value (pop bindings)))
  77                         (value (EVAL (pop bindings) env*)))
  78                     (mal-env-set env* key value)))
  79                 (setq env env*
  80                       ast form))) ; TCO
  81              ((eq a0* 'quote)
  82               (throw 'return a1))
  83              ((eq a0* 'quasiquote)
  84               (setq ast (quasiquote a1))) ; TCO
  85              ((eq a0* 'do)
  86               (let* ((a0... (cdr a))
  87                      (butlast (butlast a0...))
  88                      (last (car (last a0...))))
  89                 (when butlast
  90                   (eval-ast (mal-list butlast) env))
  91                 (setq ast last))) ; TCO
  92              ((eq a0* 'if)
  93               (let* ((condition (EVAL a1 env))
  94                      (condition-type (mal-type condition))
  95                      (then a2)
  96                      (else a3))
  97                 (if (and (not (eq condition-type 'false))
  98                          (not (eq condition-type 'nil)))
  99                     (setq ast then) ; TCO
 100                   (if else
 101                       (setq ast else) ; TCO
 102                     (throw 'return (mal-nil))))))
 103              ((eq a0* 'fn*)
 104               (let* ((binds (mapcar 'mal-value (mal-value a1)))
 105                      (body a2)
 106                      (fn (mal-fn
 107                           (lambda (&rest args)
 108                             (let ((env* (mal-env env binds args)))
 109                               (EVAL body env*))))))
 110                 (throw 'return (mal-func body binds env fn))))
 111              (t
 112               ;; not a special form
 113               (let* ((ast* (mal-value (eval-ast ast env)))
 114                      (fn (car ast*))
 115                      (args (cdr ast*)))
 116                 (if (mal-func-p fn)
 117                     (let ((env* (mal-env (mal-func-env fn)
 118                                          (mal-func-params fn)
 119                                          args)))
 120                       (setq env env*
 121                             ast (mal-func-ast fn))) ; TCO
 122                   ;; built-in function
 123                   (let ((fn* (mal-value fn)))
 124                     (throw 'return (apply fn* args))))))))
 125         (throw 'return (eval-ast ast env))))))
 126
 127 (defun eval-ast (ast env)
 128   (let ((type (mal-type ast))
 129         (value (mal-value ast)))
 130     (cond
 131      ((eq type 'symbol)
 132       (let ((definition (mal-env-get env value)))
 133         (or definition (error "Definition not found"))))
 134      ((eq type 'list)
 135       (mal-list (mapcar (lambda (item) (EVAL item env)) value)))
 136      ((eq type 'vector)
 137       (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value))))
 138      ((eq type 'map)
 139       (let ((map (copy-hash-table value)))
 140         (maphash (lambda (key value)
 141                    (puthash key (EVAL value env) map))
 142                  map)
 143         (mal-map map)))
 144      (t
 145       ;; return as is
 146       ast))))
 147
 148 (mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env)))))
 149 (mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string argv)))
 150
 151 (defun PRINT (input)
 152   (pr-str input t))
 153
 154 (defun rep (input)
 155   (PRINT (EVAL (READ input) repl-env)))
 156
 157 (rep "(def! not (fn* (a) (if a false true)))")
 158 (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
 159
 160 (defun readln (prompt)
 161   ;; C-d throws an error
 162   (ignore-errors (read-from-minibuffer prompt)))
 163
 164 (defun println (format-string &rest args)
 165   (if (not args)
 166       (princ format-string)
 167     (princ (apply 'format format-string args)))
 168   (terpri))
 169
 170 (defmacro with-error-handling (&rest body)
 171   `(condition-case err
 172        (progn ,@body)
 173      (end-of-token-stream
 174       ;; empty input, carry on
 175       )
 176      (unterminated-sequence
 177       (let* ((type (cadr err))
 178              (end
 179               (cond
 180                ((eq type 'string) ?\")
 181                ((eq type 'list) ?\))
 182                ((eq type 'vector) ?\])
 183                ((eq type 'map) ?}))))
 184         (princ (format "Expected '%c', got EOF\n" end))))
 185      (error ; catch-all
 186       (println (error-message-string err)))))
 187
 188 (defun main ()
 189   (if argv
 190       (with-error-handling
 191        (rep (format "(load-file \"%s\")" (car argv))))
 192     (let (eof)
 193       (while (not eof)
 194         (let ((input (readln "user> ")))
 195           (if input
 196               (with-error-handling
 197                (println (rep input)))
 198             (setq eof t)
 199             ;; print final newline
 200             (terpri)))))))
 201
 202 (main)