2016-03-01 17:44:09 +03:00
|
|
|
;; -*- lexical-binding: t; -*-
|
|
|
|
|
2020-07-21 19:01:48 +03:00
|
|
|
(require 'cl-lib)
|
2019-02-25 18:37:24 +03:00
|
|
|
(require 'mal/types)
|
|
|
|
(require 'mal/env)
|
|
|
|
(require 'mal/reader)
|
|
|
|
(require 'mal/printer)
|
|
|
|
(require 'mal/core)
|
2016-03-01 17:44:09 +03:00
|
|
|
|
2020-07-21 19:01:48 +03:00
|
|
|
(defun qq-reducer (elt acc)
|
2024-08-26 14:28:46 +03:00
|
|
|
(let ((value (mal-list-value elt)))
|
|
|
|
(mal-list (if (eq 'splice-unquote (mal-symbol-value (car value)))
|
|
|
|
(list (mal-symbol 'concat) (cadr value) acc)
|
|
|
|
(list (mal-symbol 'cons) (quasiquote elt) acc)))))
|
2020-07-21 19:01:48 +03:00
|
|
|
|
|
|
|
(defun qq-iter (elts)
|
|
|
|
(cl-reduce 'qq-reducer elts :from-end t :initial-value (mal-list nil)))
|
2016-03-01 17:44:09 +03:00
|
|
|
|
|
|
|
(defun quasiquote (ast)
|
2024-08-26 14:28:46 +03:00
|
|
|
(let (value)
|
|
|
|
(cond
|
|
|
|
((setq value (mal-list-value ast)) ; not empty
|
|
|
|
(if (eq 'unquote (mal-symbol-value (car value)))
|
|
|
|
(cadr value)
|
|
|
|
(qq-iter value)))
|
|
|
|
((setq value (mal-vector-value ast))
|
|
|
|
(mal-list (list (mal-symbol 'vec) (qq-iter value))))
|
|
|
|
((or (mal-map-value ast)
|
|
|
|
(mal-symbol-value ast))
|
|
|
|
(mal-list (list (mal-symbol 'quote) ast)))
|
|
|
|
(t ; including the empty list case
|
|
|
|
ast))))
|
2016-03-01 17:44:09 +03:00
|
|
|
|
|
|
|
(defun READ (input)
|
|
|
|
(read-str input))
|
|
|
|
|
|
|
|
(defun EVAL (ast env)
|
2024-08-26 14:28:46 +03:00
|
|
|
(let (return a)
|
|
|
|
(while (not return)
|
2016-03-01 17:44:09 +03:00
|
|
|
|
2022-01-10 02:15:40 +03:00
|
|
|
(let ((dbgeval (mal-env-get env 'DEBUG-EVAL)))
|
2024-08-26 14:28:46 +03:00
|
|
|
(if (not (memq dbgeval (list nil mal-nil mal-false)))
|
2022-01-10 02:15:40 +03:00
|
|
|
(println "EVAL: %s\n" (PRINT ast))))
|
|
|
|
|
2024-08-26 14:28:46 +03:00
|
|
|
(cond
|
2016-03-01 17:44:09 +03:00
|
|
|
|
2024-08-26 14:28:46 +03:00
|
|
|
((setq a (mal-list-value ast))
|
|
|
|
(cl-case (mal-symbol-value (car a))
|
2020-07-21 19:01:48 +03:00
|
|
|
(def!
|
2024-08-26 14:28:46 +03:00
|
|
|
(let ((identifier (mal-symbol-value (cadr a)))
|
|
|
|
(value (EVAL (caddr a) env)))
|
|
|
|
(setq return (mal-env-set env identifier value))))
|
2020-07-21 19:01:48 +03:00
|
|
|
(let*
|
2024-08-26 14:28:46 +03:00
|
|
|
(let ((env* (mal-env env))
|
|
|
|
(bindings (mal-seq-value (cadr a)))
|
|
|
|
(form (caddr a))
|
|
|
|
key)
|
|
|
|
(seq-do (lambda (current)
|
|
|
|
(if key
|
|
|
|
(let ((value (EVAL current env*)))
|
|
|
|
(mal-env-set env* key value)
|
|
|
|
(setq key nil))
|
|
|
|
(setq key (mal-symbol-value current))))
|
|
|
|
bindings)
|
2016-03-01 17:44:09 +03:00
|
|
|
(setq env env*
|
|
|
|
ast form))) ; TCO
|
2020-07-21 19:01:48 +03:00
|
|
|
(quote
|
2024-08-26 14:28:46 +03:00
|
|
|
(setq return (cadr a)))
|
2020-07-21 19:01:48 +03:00
|
|
|
(quasiquote
|
2024-08-26 14:28:46 +03:00
|
|
|
(setq ast (quasiquote (cadr a)))) ; TCO
|
2020-07-21 19:01:48 +03:00
|
|
|
(defmacro!
|
2024-08-26 14:28:46 +03:00
|
|
|
(let ((identifier (mal-symbol-value (cadr a)))
|
|
|
|
(value (mal-macro (mal-func-value (EVAL (caddr a) env)))))
|
|
|
|
(setq return (mal-env-set env identifier value))))
|
2020-07-21 19:01:48 +03:00
|
|
|
(try*
|
2024-08-26 14:28:46 +03:00
|
|
|
(if (cddr a)
|
2016-03-01 17:44:09 +03:00
|
|
|
(condition-case err
|
2024-08-26 14:28:46 +03:00
|
|
|
(setq return (EVAL (cadr a) env))
|
2016-03-01 17:44:09 +03:00
|
|
|
(error
|
2024-08-26 14:28:46 +03:00
|
|
|
(let* ((a2* (mal-list-value (caddr a)))
|
|
|
|
(identifier (mal-symbol-value (cadr a2*)))
|
|
|
|
(form (caddr a2*))
|
2016-03-01 17:44:09 +03:00
|
|
|
(err* (if (eq (car err) 'mal-custom)
|
|
|
|
;; throw
|
|
|
|
(cadr err)
|
|
|
|
;; normal error
|
|
|
|
(mal-string (error-message-string err))))
|
2024-08-26 14:28:46 +03:00
|
|
|
(env* (mal-env env)))
|
|
|
|
(mal-env-set env* identifier err*)
|
|
|
|
(setq env env*
|
|
|
|
ast form)))) ; TCO
|
|
|
|
(setq ast (cadr a)))) ; TCO
|
2020-07-21 19:01:48 +03:00
|
|
|
(do
|
2024-08-26 14:28:46 +03:00
|
|
|
(setq a (cdr a)) ; skip 'do
|
|
|
|
(while (cdr a)
|
|
|
|
(EVAL (pop a) env))
|
|
|
|
(setq ast (car a))) ; TCO
|
2020-07-21 19:01:48 +03:00
|
|
|
(if
|
2024-08-26 14:28:46 +03:00
|
|
|
(let ((condition (EVAL (cadr a) env)))
|
|
|
|
(if (memq condition (list mal-nil mal-false))
|
|
|
|
(if (cdddr a)
|
|
|
|
(setq ast (cadddr a)) ; TCO
|
|
|
|
(setq return mal-nil))
|
|
|
|
(setq ast (caddr a))))) ; TCO
|
2020-07-21 19:01:48 +03:00
|
|
|
(fn*
|
2024-08-26 14:28:46 +03:00
|
|
|
(let ((binds (mapcar 'mal-symbol-value (mal-seq-value (cadr a))))
|
|
|
|
(body (caddr a)))
|
|
|
|
(setq return (mal-func
|
2016-03-01 17:44:09 +03:00
|
|
|
(lambda (&rest args)
|
2024-08-26 14:28:46 +03:00
|
|
|
(EVAL body (mal-env env binds args)))
|
|
|
|
body binds env))))
|
2016-03-01 17:44:09 +03:00
|
|
|
(t
|
|
|
|
;; not a special form
|
2022-01-10 02:15:40 +03:00
|
|
|
(let ((fn (EVAL (car a) env))
|
2024-08-26 14:28:46 +03:00
|
|
|
(args (cdr a))
|
|
|
|
fn*)
|
|
|
|
(cond
|
|
|
|
((setq fn* (mal-macro-value fn))
|
|
|
|
(setq ast (apply fn* args))) ; TCO
|
|
|
|
((mal-func-value fn)
|
|
|
|
(setq env (mal-env (mal-func-env fn)
|
2016-03-01 17:44:09 +03:00
|
|
|
(mal-func-params fn)
|
2024-08-26 14:28:46 +03:00
|
|
|
(mapcar (lambda (x) (EVAL x env)) args))
|
|
|
|
ast (mal-func-body fn))) ; TCO
|
|
|
|
((setq fn* (mal-fn-core-value fn))
|
2016-03-01 17:44:09 +03:00
|
|
|
;; built-in function
|
2024-08-26 14:28:46 +03:00
|
|
|
(setq return (apply fn* (mapcar (lambda (x) (EVAL x env)) args))))
|
|
|
|
(t (error "cannot apply %s" (PRINT ast))))))))
|
|
|
|
((setq a (mal-symbol-value ast))
|
|
|
|
(setq return (or (mal-env-get env a)
|
|
|
|
(error "'%s' not found" a))))
|
|
|
|
((setq a (mal-vector-value ast))
|
|
|
|
(setq return
|
2022-01-10 02:15:40 +03:00
|
|
|
(mal-vector (vconcat (mapcar (lambda (item) (EVAL item env))
|
2024-08-26 14:28:46 +03:00
|
|
|
a)))))
|
|
|
|
((setq a (mal-map-value ast))
|
|
|
|
(let ((map (copy-hash-table a)))
|
2020-07-21 19:01:48 +03:00
|
|
|
(maphash (lambda (key val)
|
|
|
|
(puthash key (EVAL val env) map))
|
2016-03-01 17:44:09 +03:00
|
|
|
map)
|
2024-08-26 14:28:46 +03:00
|
|
|
(setq return (mal-map map))))
|
2016-03-01 17:44:09 +03:00
|
|
|
(t
|
|
|
|
;; return as is
|
2024-08-26 14:28:46 +03:00
|
|
|
(setq return ast))))
|
2016-03-01 17:44:09 +03:00
|
|
|
|
2024-08-26 14:28:46 +03:00
|
|
|
;; End of the TCO loop
|
|
|
|
return))
|
2016-03-01 17:44:09 +03:00
|
|
|
|
|
|
|
(defun PRINT (input)
|
|
|
|
(pr-str input t))
|
|
|
|
|
2024-08-26 14:28:46 +03:00
|
|
|
(defun rep (input repl-env)
|
2016-03-01 17:44:09 +03:00
|
|
|
(PRINT (EVAL (READ input) repl-env)))
|
|
|
|
|
|
|
|
(defun readln (prompt)
|
|
|
|
;; C-d throws an error
|
|
|
|
(ignore-errors (read-from-minibuffer prompt)))
|
|
|
|
|
|
|
|
(defun println (format-string &rest args)
|
2024-08-26 14:28:46 +03:00
|
|
|
(princ (if args
|
|
|
|
(apply 'format format-string args)
|
|
|
|
format-string))
|
2016-03-01 17:44:09 +03:00
|
|
|
(terpri))
|
|
|
|
|
|
|
|
(defmacro with-error-handling (&rest body)
|
|
|
|
`(condition-case err
|
|
|
|
(progn ,@body)
|
|
|
|
(end-of-token-stream
|
|
|
|
;; empty input, carry on
|
|
|
|
)
|
|
|
|
(unterminated-sequence
|
2020-07-21 19:01:48 +03:00
|
|
|
(princ (format "Expected '%c', got EOF\n"
|
|
|
|
(cl-case (cadr err)
|
|
|
|
(string ?\")
|
|
|
|
(list ?\))
|
|
|
|
(vector ?\])
|
|
|
|
(map ?})))))
|
2016-03-01 17:44:09 +03:00
|
|
|
(error ; catch-all
|
|
|
|
(println (error-message-string err)))))
|
|
|
|
|
|
|
|
(defun main ()
|
2024-08-26 14:28:46 +03:00
|
|
|
(defvar repl-env (mal-env))
|
|
|
|
|
|
|
|
(dolist (binding core-ns)
|
|
|
|
(let ((symbol (car binding))
|
|
|
|
(fn (cdr binding)))
|
|
|
|
(mal-env-set repl-env symbol (mal-fn-core fn))))
|
|
|
|
|
|
|
|
(mal-env-set repl-env 'eval (mal-fn-core (byte-compile (lambda (form) (EVAL form repl-env)))))
|
|
|
|
(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv))))
|
|
|
|
|
|
|
|
(rep "(def! not (fn* (a) (if a false true)))" repl-env)
|
|
|
|
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f)
|
|
|
|
\"\nnil)\")))))" repl-env)
|
|
|
|
(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)))))))" repl-env)
|
|
|
|
|
2016-03-01 17:44:09 +03:00
|
|
|
(if argv
|
|
|
|
(with-error-handling
|
2024-08-26 14:28:46 +03:00
|
|
|
(rep (format "(load-file \"%s\")" (car argv)) repl-env))
|
|
|
|
(let (input)
|
|
|
|
(while (setq input (readln "user> "))
|
2016-03-01 17:44:09 +03:00
|
|
|
(with-error-handling
|
2024-08-26 14:28:46 +03:00
|
|
|
(println (rep input repl-env))))
|
|
|
|
;; print final newline
|
|
|
|
(terpri))))
|
2016-03-01 17:44:09 +03:00
|
|
|
|
|
|
|
(main)
|