elisp/step5_tco.el

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