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