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