elisp/step7_quote.el

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