diff --git a/impls/elisp/Makefile b/impls/elisp/Makefile index 7af3113c71..18ed09c8f5 100644 --- a/impls/elisp/Makefile +++ b/impls/elisp/Makefile @@ -1,3 +1,9 @@ all: + emacs -Q --batch -L . --eval '(byte-recompile-directory "." 0)' + +# For debugging, it is sometimes useful to attempt a run without byte compation. +nocompile: clean + exec emacs -Q --batch -L . --eval "(setq text-quoting-style 'straight)" --load stepA_mal.el clean: + rm -f *.elc *~ mal/*.elc mal/*~ diff --git a/impls/elisp/mal/core.el b/impls/elisp/mal/core.el index f079bc4009..da16eb3ab2 100644 --- a/impls/elisp/mal/core.el +++ b/impls/elisp/mal/core.el @@ -1,27 +1,30 @@ -(require 'cl-lib) +(require 'seq) +(require 'mal/types) -(defun mal-seq-p (mal-object) - (memq (mal-type mal-object) '(list vector))) - -(defun mal-listify (mal-object) - (cl-ecase (mal-type mal-object) - (list (mal-value mal-object)) - (vector (append (mal-value mal-object) nil)))) +(defun mal-boolean (value) (if value mal-true mal-false)) (defun mal-= (a b) - (cl-case (mal-type a) - ((list vector) (and (mal-seq-p b) - (mal-seq-= (mal-listify a) (mal-listify b)))) - (map (and (mal-map-p b) - (mal-map-= (mal-value a) (mal-value b)))) - (t (equal (mal-value a) (mal-value b))))) + (let (va vb) + (cond + ((or (setq va (mal-seq-value a)) (mal-list-p a)) + (and (or (setq vb (mal-seq-value b)) (mal-list-p b)) + (mal-seq-= va vb))) + ((setq va (mal-number-value a)) (equal va (mal-number-value b))) + ((setq va (mal-string-value a)) (equal va (mal-string-value b))) + ((setq va (mal-symbol-value a)) (eq va (mal-symbol-value b))) + ((setq va (mal-keyword-value a)) (equal va (mal-keyword-value b))) + ((setq va (mal-map-value a)) (and (setq vb (mal-map-value b)) + (mal-map-= va vb))) + (t (eq a b))))) (defun mal-seq-= (a b) - (if a - (and b - (mal-= (car a) (car b)) - (mal-seq-= (cdr a) (cdr b))) - (null b))) + (let* ((len (seq-length a)) + (res (= len (seq-length b)))) + (while (and res (< 0 len)) + (setq len (1- len)) + (unless (mal-= (seq-elt a len) (seq-elt b len)) + (setq res nil))) + res)) (defun mal-map-= (a b) (when (= (hash-table-count a) @@ -39,14 +42,15 @@ (define-hash-table-test 'mal-= 'mal-= 'sxhash) (defun mal-conj (seq &rest args) - (let ((value (mal-value seq))) - (cl-ecase (mal-type seq) - (vector - (mal-vector (vconcat (append (append value nil) args)))) - (list - (while args - (push (pop args) value)) - (mal-list value))))) + (let (value) + (cond + ((setq value (mal-vector-value seq)) + (mal-vector (vconcat value args))) + ((setq value (mal-list-value seq)) + (mal-list (append (reverse args) value))) + ((mal-list-p seq) + (mal-list (reverse args))) + (t (error "seq: bad type"))))) (defun elisp-to-mal (arg) (cond @@ -59,7 +63,7 @@ ((stringp arg) (mal-string arg)) ((keywordp arg) - (mal-keyword arg)) + (mal-keyword (symbol-name arg))) ((symbolp arg) (mal-symbol arg)) ((consp arg) @@ -77,158 +81,181 @@ ;; represent anything else as printed arg (mal-string (format "%S" arg))))) -(defvar core-ns - `((+ . ,(mal-fn (lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))))) - (- . ,(mal-fn (lambda (a b) (mal-number (- (mal-value a) (mal-value b)))))) - (* . ,(mal-fn (lambda (a b) (mal-number (* (mal-value a) (mal-value b)))))) - (/ . ,(mal-fn (lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))))) +(defconst core-ns + '((+ . (lambda (a b) (mal-number (+ (mal-number-value a) (mal-number-value b))))) + (- . (lambda (a b) (mal-number (- (mal-number-value a) (mal-number-value b))))) + (* . (lambda (a b) (mal-number (* (mal-number-value a) (mal-number-value b))))) + (/ . (lambda (a b) (mal-number (/ (mal-number-value a) (mal-number-value b))))) - (< . ,(mal-fn (lambda (a b) (if (< (mal-value a) (mal-value b)) mal-true mal-false)))) - (<= . ,(mal-fn (lambda (a b) (if (<= (mal-value a) (mal-value b)) mal-true mal-false)))) - (> . ,(mal-fn (lambda (a b) (if (> (mal-value a) (mal-value b)) mal-true mal-false)))) - (>= . ,(mal-fn (lambda (a b) (if (>= (mal-value a) (mal-value b)) mal-true mal-false)))) + (< . (lambda (a b) (mal-boolean (< (mal-number-value a) (mal-number-value b))))) + (<= . (lambda (a b) (mal-boolean (<= (mal-number-value a) (mal-number-value b))))) + (> . (lambda (a b) (mal-boolean (> (mal-number-value a) (mal-number-value b))))) + (>= . (lambda (a b) (mal-boolean (>= (mal-number-value a) (mal-number-value b))))) - (= . ,(mal-fn (lambda (a b) (if (mal-= a b) mal-true mal-false)))) + (= . (lambda (a b) (mal-boolean (mal-= a b)))) - (list . ,(mal-fn (lambda (&rest args) (mal-list args)))) - (list? . ,(mal-fn (lambda (mal-object) (if (mal-list-p mal-object) mal-true mal-false)))) - (empty? . ,(mal-fn (lambda (seq) (if (zerop (length (mal-value seq))) mal-true mal-false)))) - (count . ,(mal-fn (lambda (seq) (mal-number (if (mal-seq-p seq) (length (mal-value seq)) 0))))) + (list . (lambda (&rest args) (mal-list args))) + (list? . (lambda (mal-object) (mal-boolean (mal-list-p mal-object)))) + (empty? . (lambda (seq) (mal-boolean (seq-empty-p (mal-seq-value seq))))) + (count . (lambda (seq) (mal-number (length (mal-seq-value seq))))) - (pr-str . ,(mal-fn (lambda (&rest args) (mal-string (mapconcat (lambda (item) (pr-str item t)) args " "))))) - (str . ,(mal-fn (lambda (&rest args) (mal-string (mapconcat 'pr-str args ""))))) - (prn . ,(mal-fn (lambda (&rest args) (println (mapconcat (lambda (item) (pr-str item t)) args " ")) mal-nil))) - (println . ,(mal-fn (lambda (&rest args) (println (mapconcat 'pr-str args " ")) mal-nil))) + (pr-str . (lambda (&rest args) (mal-string (pr-join args t " ")))) + (str . (lambda (&rest args) (mal-string (pr-join args nil "")))) + (prn . (lambda (&rest args) + (println (pr-join args t " ")) + mal-nil)) + (println . (lambda (&rest args) + (println (pr-join args nil " ")) + mal-nil)) - (read-string . ,(mal-fn (lambda (input) (read-str (mal-value input))))) - (slurp . ,(mal-fn (lambda (file) + (read-string . (lambda (input) (read-str (mal-string-value input)))) + (slurp . (lambda (file) (with-temp-buffer - (insert-file-contents-literally (mal-value file)) - (mal-string (buffer-string)))))) - - (atom . ,(mal-fn (lambda (arg) (mal-atom arg)))) - (atom? . ,(mal-fn (lambda (mal-object) (if (mal-atom-p mal-object) mal-true mal-false)))) - (deref . ,(mal-fn (lambda (atom) (mal-value atom)))) - (reset! . ,(mal-fn (lambda (atom value) (setf (aref atom 1) value)))) - (swap! . ,(mal-fn (lambda (atom fn &rest args) - (let* ((fn* (if (mal-func-p fn) (mal-func-fn fn) fn)) - (args* (cons (mal-value atom) args)) - (value (apply (mal-value fn*) args*))) - (setf (aref atom 1) value))))) - - (vec . ,(mal-fn (lambda (seq) (if (mal-vector-p seq) seq (mal-vector (mal-value seq)))))) - (cons . ,(mal-fn (lambda (arg list) (mal-list (cons arg (mal-listify list)))))) - (concat . ,(mal-fn (lambda (&rest lists) - (let ((lists* (mapcar (lambda (item) (mal-listify item)) lists))) - (mal-list (apply 'append lists*)))))) - - (nth . ,(mal-fn (lambda (seq index) - (let ((i (mal-value index)) - (list (mal-listify seq))) - (or (nth i list) - (error "Args out of range: %s, %d" (pr-str seq) i)))))) - (first . ,(mal-fn (lambda (seq) - (if (mal-nil-p seq) + (insert-file-contents-literally (mal-string-value file)) + (mal-string (buffer-string))))) + + (atom . mal-atom) + (atom? . (lambda (mal-object) (mal-boolean (mal-atom-value mal-object)))) + (deref . mal-atom-value) + (reset! . (lambda (atom value) + (mal-reset atom value) + value)) + (swap! . (lambda (atom fn &rest args) + (let ((value (apply (or (mal-func-value fn) + (mal-fn-core-value fn)) + (mal-atom-value atom) + args))) + (mal-reset atom value) + value))) + + (vec . (lambda (seq) + (if (mal-vector-value seq) + seq + (mal-vector (seq-into (mal-list-value seq) 'vector))))) + (cons . (lambda (arg seq) + (let ((value (mal-vector-value seq))) + (mal-list (cons arg (if value + (seq-into value 'list) + (mal-list-value seq))))))) + (concat . (lambda (&rest lists) + (mal-list (seq-mapcat 'mal-seq-value lists 'list)))) + + (nth . (lambda (seq index) + (let ((list (mal-seq-value seq)) + (i (mal-number-value index))) + ;; seq-elt returns nil for a list and a bad index + (or (seq-elt (mal-seq-value seq) (mal-number-value index)) + (error "Args out of range: %s, %d" (pr-str seq t) i))))) + + (first . (lambda (seq) + (let ((value (mal-seq-value seq))) + (if (seq-empty-p value) mal-nil - (or (car (mal-listify seq)) mal-nil))))) - (rest . ,(mal-fn (lambda (seq) (mal-list (unless (mal-nil-p seq) (cdr (mal-listify seq))))))) - - (throw . ,(mal-fn (lambda (mal-object) (signal 'mal-custom (list mal-object))))) - - (apply . ,(mal-fn (lambda (fn &rest args) - (let* ((butlast (butlast args)) - (last (mal-listify (car (last args)))) - (fn* (if (mal-func-p fn) (mal-func-fn fn) fn)) - (args* (append butlast last))) - (apply (mal-value fn*) args*))))) - (map . ,(mal-fn (lambda (fn seq) - (let ((fn* (if (mal-func-p fn) (mal-func-fn fn) fn))) - (mal-list (mapcar (mal-value fn*) (mal-value seq))))))) - - (nil? . ,(mal-fn (lambda (arg) (if (mal-nil-p arg) mal-true mal-false)))) - (true? . ,(mal-fn (lambda (arg) (if (mal-true-p arg) mal-true mal-false)))) - (false? . ,(mal-fn (lambda (arg) (if (mal-false-p arg) mal-true mal-false)))) - - (number? . ,(mal-fn (lambda (arg) (if (mal-number-p arg) mal-true mal-false)))) - (symbol? . ,(mal-fn (lambda (arg) (if (mal-symbol-p arg) mal-true mal-false)))) - (keyword? . ,(mal-fn (lambda (arg) (if (mal-keyword-p arg) mal-true mal-false)))) - (string? . ,(mal-fn (lambda (arg) (if (mal-string-p arg) mal-true mal-false)))) - (vector? . ,(mal-fn (lambda (arg) (if (mal-vector-p arg) mal-true mal-false)))) - (map? . ,(mal-fn (lambda (arg) (if (mal-map-p arg) mal-true mal-false)))) - - (symbol . ,(mal-fn (lambda (string) (mal-symbol (intern (mal-value string)))))) - (keyword . ,(mal-fn (lambda (x) (if (mal-keyword-p x) x (mal-keyword (intern (concat ":" (mal-value x)))))))) - (vector . ,(mal-fn (lambda (&rest args) (mal-vector (vconcat args))))) - (hash-map . ,(mal-fn (lambda (&rest args) + (seq-first value))))) + (rest . (lambda (seq) + (let ((value(mal-vector-value seq))) + (mal-list (cdr (if value + (seq-into value 'list) + (mal-list-value seq))))))) + + (throw . (lambda (mal-object) (signal 'mal-custom (list mal-object)))) + + (apply . (lambda (fn &rest args) + (let ((butlast (butlast args)) + (last (mal-seq-value (car (last args)))) + (fn* (or (mal-func-value fn) + (mal-fn-core-value fn) + (mal-macro-value fn)))) + (apply fn* (seq-concatenate 'list butlast last))))) + (map . (lambda (fn seq) + (mal-list (mapcar (or (mal-func-value fn) (mal-fn-core-value fn)) + (mal-seq-value seq))))) + + (nil? . (lambda (arg) (mal-boolean (eq mal-nil arg)))) + (true? . (lambda (arg) (mal-boolean (eq mal-true arg)))) + (false? . (lambda (arg) (mal-boolean (eq mal-false arg)))) + + (number? . (lambda (arg) (mal-boolean (mal-number-value arg)))) + (symbol? . (lambda (arg) (mal-boolean (mal-symbol-value arg)))) + (keyword? . (lambda (arg) (mal-boolean (mal-keyword-value arg)))) + (string? . (lambda (arg) (mal-boolean (mal-string-value arg)))) + (vector? . (lambda (arg) (mal-boolean (mal-vector-value arg)))) + (map? . (lambda (arg) (mal-boolean (mal-map-value arg)))) + + (symbol . (lambda (string) (mal-symbol (intern (mal-string-value string))))) + (keyword . (lambda (x) + (let ((value (mal-string-value x))) + (if value + (mal-keyword (concat ":" value)) + x)))) + + (vector . (lambda (&rest args) (mal-vector (seq-into args 'vector)))) + (hash-map . (lambda (&rest args) (let ((map (make-hash-table :test 'mal-=))) (while args (puthash (pop args) (pop args) map)) - (mal-map map))))) - - (sequential? . ,(mal-fn (lambda (mal-object) (if (mal-seq-p mal-object) mal-true mal-false)))) - (fn? . ,(mal-fn (lambda (arg) (if (or (mal-fn-p arg) - (and (mal-func-p arg) - (not (mal-func-macro-p arg)))) - mal-true - mal-false)))) - (macro? . ,(mal-fn (lambda (arg) (if (and (mal-func-p arg) - (mal-func-macro-p arg)) - mal-true - mal-false)))) - - (get . ,(mal-fn (lambda (map key) (if (mal-map-p map) (or (gethash key (mal-value map)) mal-nil) mal-nil)))) - (contains? . ,(mal-fn (lambda (map key) (if (gethash key (mal-value map)) mal-true mal-false)))) - (assoc . ,(mal-fn (lambda (map &rest args) - (let ((map* (copy-hash-table (mal-value map)))) + (mal-map map)))) + + (sequential? . (lambda (mal-object) + (mal-boolean (or (mal-list-p mal-object) + (mal-vector-value mal-object))))) + (fn? . (lambda (arg) (mal-boolean (or (mal-fn-core-value arg) + (mal-func-value arg))))) + (macro? . (lambda (arg) (mal-boolean (mal-macro-value arg)))) + + (get . (lambda (map key) + (or (let ((value (mal-map-value map))) + (when value + (gethash key value))) + mal-nil))) + (contains? . (lambda (map key) + (mal-boolean (gethash key (mal-map-value map))))) + (assoc . (lambda (map &rest args) + (let ((map* (copy-hash-table (mal-map-value map)))) (while args (puthash (pop args) (pop args) map*)) - (mal-map map*))))) - (dissoc . ,(mal-fn (lambda (map &rest args) - (let ((map* (copy-hash-table (mal-value map)))) - (while args - (remhash (pop args) map*)) - (mal-map map*))))) - (keys . ,(mal-fn (lambda (map) (let (keys) - (maphash (lambda (key value) (push key keys)) - (mal-value map)) - (mal-list keys))))) - (vals . ,(mal-fn (lambda (map) (let (vals) - (maphash (lambda (key value) (push value vals)) - (mal-value map)) - (mal-list vals))))) - - (readline . ,(mal-fn (lambda (prompt) - (let ((ret (readln (mal-value prompt)))) - (if ret - (mal-string ret) - mal-nil))))) - - (meta . ,(mal-fn (lambda (mal-object) (or (mal-meta mal-object) mal-nil)))) - (with-meta . ,(mal-fn (lambda (mal-object meta) - (let ((mal-object* (copy-sequence mal-object))) - (setf (aref mal-object* 2) meta) - mal-object*)))) - - (time-ms . ,(mal-fn (lambda () (mal-number (floor (* (float-time) 1000)))))) - - (conj . ,(mal-fn 'mal-conj)) - (seq . ,(mal-fn (lambda (mal-object) - (let ((type (mal-type mal-object)) - (value (mal-value mal-object))) + (mal-map map*)))) + (dissoc . (lambda (map &rest args) + (let ((map* (copy-hash-table (mal-map-value map)))) + (dolist (k args) + (remhash k map*)) + (mal-map map*)))) + (keys . (lambda (map) (let (keys) + (maphash (lambda (key _value) (push key keys)) + (mal-map-value map)) + (mal-list keys)))) + (vals . (lambda (map) (let (vals) + (maphash (lambda (_key value) (push value vals)) + (mal-map-value map)) + (mal-list vals)))) + + (readline . (lambda (prompt) + (or (mal-string (readln (mal-string-value prompt))) + mal-nil))) + + (meta . mal-meta) + (with-meta . with-meta) + + (time-ms . (lambda () (mal-number (floor (* (float-time) 1000))))) + + (conj . mal-conj) + (seq . (lambda (mal-object) + (let (value) + (or (cond - ((or (eq type 'list) (eq type 'vector)) - (if (and value (not (zerop (length value)))) - (mal-list (mal-listify mal-object)) - mal-nil)) - ((eq type 'string) - (if (not (zerop (length value))) - (mal-list (mapcar (lambda (item) (mal-string (char-to-string item))) - (append value nil))) - mal-nil)) - (t - mal-nil)))))) - - (elisp-eval . ,(mal-fn (lambda (string) (elisp-to-mal (eval (read (mal-value string))))))) + ((setq value (mal-list-value mal-object)) + mal-object) + ((and (setq value (mal-vector-value mal-object)) + (not (seq-empty-p value))) + (mal-list (seq-into value 'list))) + ((and (setq value (mal-string-value mal-object)) + (not (seq-empty-p value))) + (mal-list (mapcar (lambda (item) (mal-string (char-to-string item))) + value)))) + mal-nil)))) + + (elisp-eval . (lambda (string) + (elisp-to-mal (eval (read (mal-string-value string)))))) )) (provide 'mal/core) diff --git a/impls/elisp/mal/env.el b/impls/elisp/mal/env.el index 94f6d3e717..4500e37a25 100644 --- a/impls/elisp/mal/env.el +++ b/impls/elisp/mal/env.el @@ -1,28 +1,27 @@ +(require 'mal/types) + +;; An env is represented by an elisp list of hash-tables. In other words +;; * car: a hash-table +;; * cdr: the outer environment or () +;; Keys are elisp symbols. + (defun mal-env (&optional outer binds exprs) - (let ((env (vector 'env (vector (make-hash-table :test 'eq) outer)))) - (while binds - (let ((key (pop binds))) - (if (eq key '&) - (let ((key (pop binds)) - (value (mal-list exprs))) - (mal-env-set env key value) - (setq binds nil - exprs nil)) - (let ((value (pop exprs))) - (mal-env-set env key value))))) + (let ((env (cons (make-hash-table :test 'eq) outer)) + key) + (while (setq key (pop binds)) + (if (eq key '&) + (mal-env-set env (pop binds) (mal-list exprs)) + (mal-env-set env key (pop exprs)))) env)) (defun mal-env-set (env key value) - (let ((data (aref (aref env 1) 0))) + (let ((data (car env))) (puthash key value data))) (defun mal-env-get (env key) - (let* ((data (aref (aref env 1) 0)) - (value (gethash key data))) - (or value - (let ((outer (aref (aref env 1) 1))) - (if outer - (mal-env-get outer key) - nil))))) + (let (value) + (while (and (not (setq value (gethash key (pop env)))) + env)) + value)) (provide 'mal/env) diff --git a/impls/elisp/mal/func.el b/impls/elisp/mal/func.el deleted file mode 100644 index 8e4547ffda..0000000000 --- a/impls/elisp/mal/func.el +++ /dev/null @@ -1,25 +0,0 @@ -(defun mal-func (ast params env fn) - (vector 'func (vector ast params env fn nil) nil)) - -(defun mal-macro (mal-func) - (let ((v (aref mal-func 1))) - (vector 'func - (vector (aref v 0) (aref v 1) (aref v 2) (aref v 3) t) - nil))) - -(defun mal-func-ast (mal-func) - (aref (aref mal-func 1) 0)) - -(defun mal-func-params (mal-func) - (aref (aref mal-func 1) 1)) - -(defun mal-func-env (mal-func) - (aref (aref mal-func 1) 2)) - -(defun mal-func-fn (mal-func) - (aref (aref mal-func 1) 3)) - -(defun mal-func-macro-p (mal-func) - (aref (aref mal-func 1) 4)) - -(provide 'mal/func) diff --git a/impls/elisp/mal/printer.el b/impls/elisp/mal/printer.el index 6e09f23cef..46d2f97c11 100644 --- a/impls/elisp/mal/printer.el +++ b/impls/elisp/mal/printer.el @@ -1,59 +1,60 @@ -(require 'cl-lib) +(require 'mal/types) -(defun pr-str (form &optional print-readably) - (let ((value (mal-value form))) - (cl-ecase (mal-type form) - ('nil +(defun pr-str (form print-readably) + (let (value) + (cond + ((eq mal-nil form) "nil") - (true + ((eq mal-true form) "true") - (false + ((eq mal-false form) "false") - (number + ((setq value (mal-number-value form)) (number-to-string value)) - (string + ((setq value (mal-string-value form)) (if print-readably (let ((print-escape-newlines t)) (prin1-to-string value)) value)) - ((symbol keyword) + ((setq value (mal-symbol-value form)) (symbol-name value)) - (list + ((setq value (mal-keyword-value form)) + value) + ((setq value (mal-list-value form)) (pr-list value print-readably)) - (vector + ((mal-list-p form) + "()") + ((setq value (mal-vector-value form)) (pr-vector value print-readably)) - (map + ((setq value (mal-map-value form)) (pr-map value print-readably)) - (fn - "#") - (func - "#") - (atom - (format "(atom %s)" (pr-str value print-readably)))))) + ((or (mal-fn-core-value form) (mal-func-value form)) + "#") + ((mal-macro-value form) + "#") + ((setq value (mal-atom-value form)) + (format "(atom %s)" (pr-str value print-readably))) + (t (error "pr-str: unknown type: %s" form))))) (defun pr-list (form print-readably) - (let ((items (mapconcat - (lambda (item) (pr-str item print-readably)) - form " "))) + (let ((items (pr-join form print-readably " "))) (concat "(" items ")"))) (defun pr-vector (form print-readably) - (let ((items (mapconcat - (lambda (item) (pr-str item print-readably)) - (append form nil) " "))) + (let ((items (pr-join form print-readably " "))) (concat "[" items "]"))) (defun pr-map (form print-readably) (let (pairs) (maphash (lambda (key value) - (push (cons (pr-str key print-readably) - (pr-str value print-readably)) - pairs)) + (push value pairs) + (push key pairs)) form) - (let ((items (mapconcat - (lambda (item) (concat (car item) " " (cdr item))) - (nreverse pairs) " "))) + (let ((items (pr-join pairs print-readably " "))) (concat "{" items "}")))) +(defun pr-join (forms print-readably separator) + (mapconcat (lambda (item) (pr-str item print-readably)) forms separator)) + (provide 'mal/printer) diff --git a/impls/elisp/mal/reader.el b/impls/elisp/mal/reader.el index c8b92835fc..8253cd98f1 100644 --- a/impls/elisp/mal/reader.el +++ b/impls/elisp/mal/reader.el @@ -1,20 +1,20 @@ -(require 'cl-lib) +(require 'mal/types) ;; HACK: `text-quoting-style' prettifies quotes in error messages on ;; Emacs 25, but no longer does from 26 upwards... (when (= emacs-major-version 25) (setq text-quoting-style 'grave)) -(defvar tokens nil) +(defvar reader--tokens nil) (defun peek () - (car tokens)) + (car reader--tokens)) (defun next () - (pop tokens)) + (pop reader--tokens)) (defun read-str (input) - (setq tokens (tokenizer input)) + (setq reader--tokens (tokenizer input)) (read-form)) (defun tokenizer (input) @@ -149,7 +149,7 @@ (mal-string (read token)) (signal 'unterminated-sequence '(string)))) ((= (aref token 0) ?:) - (mal-keyword (intern token))) + (mal-keyword token)) (t ;; assume anything else is a symbol (mal-symbol (intern token)))) diff --git a/impls/elisp/mal/types.el b/impls/elisp/mal/types.el index e87e41c8d6..deba03a46c 100644 --- a/impls/elisp/mal/types.el +++ b/impls/elisp/mal/types.el @@ -1,45 +1,95 @@ -;;; general accessors +;; Structural pattern matching is ideal, but too slow for MAL. -(defun mal-type (mal-object) - (aref mal-object 0)) - -(defun mal-value (mal-object) - (aref mal-object 1)) - -(defun mal-meta (mal-object) - (aref mal-object 2)) - -;;; objects +;; So we use a mal-foo-value getter that returns nil in case of bad +;; type (or if a list is empty, unfortunately). (defmacro mal-object (name) (let ((constructor (intern (format "mal-%s" name))) - (predicate (intern (format "mal-%s-p" name)))) + (accessor (intern (format "mal-%s-value" name)))) `(progn - (defun ,constructor (&optional value meta) - (vector ',name value meta)) - (defun ,predicate (arg) - (and (vectorp arg) (eq (aref arg 0) ',name)))))) - -(mal-object nil) -(mal-object true) -(mal-object false) - -(defvar mal-nil (mal-nil)) -(defvar mal-true (mal-true 'true)) -(defvar mal-false (mal-false 'false)) - -(mal-object number) -(mal-object string) -(mal-object symbol) + (defsubst ,constructor (value) + (record ',name value)) + (defun ,accessor (arg) + (and (recordp arg) + (eq (aref arg 0) ',name) + (aref arg 1)))))) + +(defconst mal-nil #&8"n") +(defconst mal-false #&8"f") +(defconst mal-true #&8"t") + +(defsubst mal-number (elisp-number) elisp-number) +(defsubst mal-number-value (obj) (and (numberp obj) obj)) + +(defsubst mal-symbol (elisp-symbol) elisp-symbol) +;; A nil result means either 'not a symbol' or 'the nil symbol'. +(defsubst mal-symbol-value (obj) (and (symbolp obj)obj)) + +(defsubst mal-string (elisp-string) elisp-string) +(defsubst mal-string-value (obj) (and (stringp obj) obj)) + +;; In elisp, keywords are symbols. Using them would cause confusion, +;; or at least make mal-symbol-value more complex, for little benefit. +;; The wrapped value is an elisp string including the initial colon. (mal-object keyword) -(mal-object list) -(mal-object vector) -(mal-object map) +;; Use the native type when possible, but #s(type value meta ...) for +;; the empty list or when metadata is present. + +(defsubst mal-vector (elisp-vector) elisp-vector) +(defun mal-vector-value (obj) + (if (vectorp obj) + obj + (and (recordp obj) (eq (aref obj 0) 'vector) (aref obj 1)))) + +(defsubst mal-map (elisp-hash-table) elisp-hash-table) +(defun mal-map-value (obj) + (if (hash-table-p obj) + obj + (and (recordp obj) (eq (aref obj 0) 'map) (aref obj 1)))) + +(defconst mal-empty-list #s(list nil)) +(defsubst mal-list (elisp-list) (or elisp-list mal-empty-list)) +;; A nil result means either 'not a list' or 'empty list'. +(defun mal-list-value (obj) + (if (listp obj) obj + (and (recordp obj) (eq (aref obj 0) 'list) (aref obj 1)))) +(defun mal-list-p (obj) + (or (listp obj) + (and (recordp obj) (eq (aref obj 0) 'list)))) + +;; A nil result means either 'not a list' or 'empty list'. +(defun mal-seq-value (arg) (or (mal-vector-value arg) (mal-list-value arg))) (mal-object atom) -(mal-object fn) -(mal-object func) +(defun mal-reset (atom value) (setf (aref atom 1) value)) + +(mal-object fn-core) +(mal-object macro) + +;; Function created by fn*. +(defsubst mal-func (value body params env) + (record 'func value body params env)) +(defun mal-func-value ( obj) + (and (recordp obj) (eq (aref obj 0) 'func) (aref obj 1))) +(defsubst mal-func-body (obj) (aref obj 2)) +(defsubst mal-func-params (obj) (aref obj 3)) +(defsubst mal-func-env (obj) (aref obj 4)) + +(defun with-meta (obj meta) + (cond + ((vectorp obj) (record 'vector obj meta)) + ((hash-table-p obj) (record 'map obj meta)) + ((listp obj) (record 'list obj meta)) + ((< (length obj) 4) (record (aref obj 0) (aref obj 1) meta)) + (t (record (aref obj 0) (aref obj 1) + (aref obj 2) (aref obj 3) + (aref obj 4) meta)))) + +(defun mal-meta (obj) + (if (and (recordp obj) (member (length obj) '(3 6))) + (aref obj (1- (length obj))) + mal-nil)) ;;; regex diff --git a/impls/elisp/run b/impls/elisp/run index c68e97bf93..cb0387403c 100755 --- a/impls/elisp/run +++ b/impls/elisp/run @@ -1,2 +1,3 @@ -#!/bin/bash -exec emacs -Q --batch -L $(dirname $0) --eval "(setq text-quoting-style 'straight)" --load $(dirname $0)/${STEP:-stepA_mal}.el "${@}" +#!/bin/sh +dir=$(dirname $0) +exec emacs -Q --batch -L $dir --eval "(setq text-quoting-style 'straight)" --load $dir/${STEP:-stepA_mal}.elc "${@}" diff --git a/impls/elisp/step0_repl.el b/impls/elisp/step0_repl.el index 49bc0a78d9..c8cadfcf9c 100644 --- a/impls/elisp/step0_repl.el +++ b/impls/elisp/step0_repl.el @@ -7,24 +7,24 @@ (defun PRINT (input) input) +(defun rep (input) + (PRINT (EVAL (READ input)))) + (defun readln (prompt) ;; C-d throws an error (ignore-errors (read-from-minibuffer prompt))) (defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) + (princ (if args + (apply 'format format-string args) + format-string)) (terpri)) (defun main () - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (println input) - (setq eof t) - ;; print final newline - (terpri)))))) + (let (input) + (while (setq input (readln "user> ")) + (println (rep input))) + ;; print final newline + (terpri))) (main) diff --git a/impls/elisp/step1_read_print.el b/impls/elisp/step1_read_print.el index 2e109a00da..a3f93ed67f 100644 --- a/impls/elisp/step1_read_print.el +++ b/impls/elisp/step1_read_print.el @@ -1,7 +1,11 @@ +;; -*- lexical-binding: t; -*- + +(require 'cl-lib) (require 'mal/types) (require 'mal/reader) (require 'mal/printer) + (defun READ (input) (read-str input)) @@ -19,33 +23,33 @@ (ignore-errors (read-from-minibuffer prompt))) (defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) + (princ (if args + (apply 'format format-string args) + format-string)) (terpri)) +(defmacro with-error-handling (&rest body) + `(condition-case err + (progn ,@body) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err))))) + (defun main () - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (condition-case err - (println (rep input)) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err)) - (backtrace))) - (setq eof t) - ;; print final newline - (terpri)))))) + (let (input) + (while (setq input (readln "user> ")) + (with-error-handling + (println (rep input)))) + ;; print final newline + (terpri))) (main) diff --git a/impls/elisp/step2_eval.el b/impls/elisp/step2_eval.el index 6b76b75d7b..b069f71705 100644 --- a/impls/elisp/step2_eval.el +++ b/impls/elisp/step2_eval.el @@ -1,46 +1,43 @@ +;; -*- lexical-binding: t; -*- + +(require 'cl-lib) (require 'mal/types) (require 'mal/reader) (require 'mal/printer) -(defvar repl-env (make-hash-table :test 'eq)) -(puthash '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))) repl-env) -(puthash '- (lambda (a b) (mal-number (- (mal-value a) (mal-value b)))) repl-env) -(puthash '* (lambda (a b) (mal-number (* (mal-value a) (mal-value b)))) repl-env) -(puthash '/ (lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))) repl-env) (defun READ (input) (read-str input)) (defun EVAL (ast env) - ;; (println "EVAL: %s\n" (PRINT ast)) - (cl-case (mal-type ast) - (list - (let ((a (mal-value ast))) - (if a - (let* ((fn (EVAL (car a) env)) - (args (mapcar (lambda (x) (EVAL x env)) (cdr a)))) - (apply fn args)) - ast))) - (symbol - (let ((definition (gethash (mal-value ast) env))) - (or definition (error "Definition not found")))) - (vector - (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) - (mal-value ast))))) - (map - (let ((map (copy-hash-table (mal-value ast)))) + (let (a) + + ;; (println "EVAL: %s\n" (PRINT ast)) + + (cond + + ((setq a (mal-list-value ast)) + (let ((fn* (mal-fn-core-value (EVAL (car a) env))) + (args (mapcar (lambda (x) (EVAL x env)) (cdr a)))) + (apply fn* args))) + ((setq a (mal-symbol-value ast)) + (or (gethash a env) (error "'%s' not found" a))) + ((setq a (mal-vector-value ast)) + (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) a)))) + ((setq a (mal-map-value ast)) + (let ((map (copy-hash-table a))) (maphash (lambda (key val) (puthash key (EVAL val env) map)) map) (mal-map map))) (t ;; return as is - ast))) + ast)))) (defun PRINT (input) (pr-str input t)) -(defun rep (input) +(defun rep (input repl-env) (PRINT (EVAL (READ input) repl-env))) (defun readln (prompt) @@ -48,33 +45,44 @@ (ignore-errors (read-from-minibuffer prompt))) (defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) + (princ (if args + (apply 'format format-string args) + format-string)) (terpri)) +(defmacro with-error-handling (&rest body) + `(condition-case err + (progn ,@body) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err))))) + (defun main () - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (condition-case err - (println (rep input)) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err)) - (backtrace))) - (setq eof t) - ;; print final newline - (terpri)))))) + (defvar repl-env (make-hash-table :test 'eq)) + + (dolist (binding + '((+ . (lambda (a b) (mal-number (+ (mal-number-value a) (mal-number-value b))))) + (- . (lambda (a b) (mal-number (- (mal-number-value a) (mal-number-value b))))) + (* . (lambda (a b) (mal-number (* (mal-number-value a) (mal-number-value b))))) + (/ . (lambda (a b) (mal-number (/ (mal-number-value a) (mal-number-value b))))))) + (let ((symbol (car binding)) + (fn (cdr binding))) + (puthash symbol (mal-fn-core fn) repl-env))) + + (let (input) + (while (setq input (readln "user> ")) + (with-error-handling + (println (rep input repl-env)))) + ;; print final newline + (terpri))) (main) diff --git a/impls/elisp/step3_env.el b/impls/elisp/step3_env.el index a003e55144..91d7f79114 100644 --- a/impls/elisp/step3_env.el +++ b/impls/elisp/step3_env.el @@ -1,71 +1,66 @@ +;; -*- lexical-binding: t; -*- + +(require 'cl-lib) (require 'mal/types) (require 'mal/env) (require 'mal/reader) (require 'mal/printer) -(defvar repl-env (mal-env)) -(mal-env-set repl-env '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) -(mal-env-set repl-env '- (lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) -(mal-env-set repl-env '* (lambda (a b) (mal-number (* (mal-value a) (mal-value b))))) -(mal-env-set repl-env '/ (lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))) (defun READ (input) (read-str input)) (defun EVAL (ast env) - (let ((dbgeval (mal-env-get env 'DEBUG-EVAL))) - (if (and dbgeval - (not (member (mal-type dbgeval) '(false nil)))) - (println "EVAL: %s\n" (PRINT ast)))) - - (cl-case (mal-type ast) - (list - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a))) - (if a - (cl-case (mal-value (car a)) + (let (a) + + (let ((dbgeval (mal-env-get env 'DEBUG-EVAL))) + (if (not (memq dbgeval (list nil mal-nil mal-false))) + (println "EVAL: %s\n" (PRINT ast)))) + + (cond + + ((setq a (mal-list-value ast)) + (cl-case (mal-symbol-value (car a)) (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (mal-env-set env identifier value))) + (let ((identifier (mal-symbol-value (cadr a))) + (value (EVAL (caddr a) env))) + (mal-env-set env identifier value))) (let* - (let* ((env* (mal-env env)) - (a1* (mal-value a1)) - (bindings (if (vectorp a1*) (append a1* nil) a1*)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) + (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) (EVAL form env*))) (t ;; not a special form - (let ((fn (EVAL (car a) env)) + (let ((fn* (mal-fn-core-value (EVAL (car a) env))) (args (mapcar (lambda (x) (EVAL x env)) (cdr a)))) - (apply fn args)))) - ast))) - (symbol - (let ((key (mal-value ast))) - (or (mal-env-get env key) - (error "'%s' not found" key)))) - (vector - (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) - (mal-value ast))))) - (map - (let ((map (copy-hash-table (mal-value ast)))) + (apply fn* args))))) + ((setq a (mal-symbol-value ast)) + (or (mal-env-get env a) (error "'%s' not found" a))) + ((setq a (mal-vector-value ast)) + (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) a)))) + ((setq a (mal-map-value ast)) + (let ((map (copy-hash-table a))) (maphash (lambda (key val) (puthash key (EVAL val env) map)) map) (mal-map map))) (t ;; return as is - ast))) + ast)))) (defun PRINT (input) (pr-str input t)) -(defun rep (input) +(defun rep (input repl-env) (PRINT (EVAL (READ input) repl-env))) (defun readln (prompt) @@ -73,32 +68,44 @@ (ignore-errors (read-from-minibuffer prompt))) (defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) + (princ (if args + (apply 'format format-string args) + format-string)) (terpri)) +(defmacro with-error-handling (&rest body) + `(condition-case err + (progn ,@body) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err))))) + (defun main () - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (condition-case err - (println (rep input)) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err)))) - (setq eof t) - ;; print final newline - (terpri)))))) + (defvar repl-env (mal-env)) + + (dolist (binding + '((+ . (lambda (a b) (mal-number (+ (mal-number-value a) (mal-number-value b))))) + (- . (lambda (a b) (mal-number (- (mal-number-value a) (mal-number-value b))))) + (* . (lambda (a b) (mal-number (* (mal-number-value a) (mal-number-value b))))) + (/ . (lambda (a b) (mal-number (/ (mal-number-value a) (mal-number-value b))))))) + (let ((symbol (car binding)) + (fn (cdr binding))) + (mal-env-set repl-env symbol (mal-fn-core fn)))) + + (let (input) + (while (setq input (readln "user> ")) + (with-error-handling + (println (rep input repl-env)))) + ;; print final newline + (terpri))) (main) diff --git a/impls/elisp/step4_if_fn_do.el b/impls/elisp/step4_if_fn_do.el index d0a9f96072..0dce5e9b2c 100644 --- a/impls/elisp/step4_if_fn_do.el +++ b/impls/elisp/step4_if_fn_do.el @@ -1,134 +1,138 @@ ;; -*- lexical-binding: t; -*- +(require 'cl-lib) (require 'mal/types) (require 'mal/env) (require 'mal/reader) (require 'mal/printer) (require 'mal/core) -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - (defun READ (input) (read-str input)) (defun EVAL (ast env) - (let ((dbgeval (mal-env-get env 'DEBUG-EVAL))) - (if (and dbgeval - (not (member (mal-type dbgeval) '(false nil)))) - (println "EVAL: %s\n" (PRINT ast)))) - - (cl-case (mal-type ast) - (list - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (if a - (cl-case (mal-value (car a)) + (let (a) + + (let ((dbgeval (mal-env-get env 'DEBUG-EVAL))) + (if (not (memq dbgeval (list nil mal-nil mal-false))) + (println "EVAL: %s\n" (PRINT ast)))) + + (cond + + ((setq a (mal-list-value ast)) + (cl-case (mal-symbol-value (car a)) (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (mal-env-set env identifier value))) + (let ((identifier (mal-symbol-value (cadr a))) + (value (EVAL (caddr a) env))) + (mal-env-set env identifier value))) (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) + (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) (EVAL form env*))) (do - (let* ((a0... (cdr a)) - (butlast (butlast a0...)) - (last (car (last a0...)))) - (mapcar (lambda (item) (EVAL item env)) butlast) - (EVAL last env))) + (setq a (cdr a)) ; skip 'do + (while (cdr a) + (EVAL (pop a) env)) + (EVAL (car a) env)) (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (EVAL then env) - (if else - (EVAL else env) - mal-nil)))) + (let ((condition (EVAL (cadr a) env))) + (if (memq condition (list mal-nil mal-false)) + (if (cdddr a) + (EVAL (cadddr a) env) + mal-nil) + (EVAL (caddr a) env)))) (fn* - (let ((binds (mapcar 'mal-value (mal-value a1))) - (body a2)) - (mal-fn - (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) + (let ((binds (mapcar 'mal-symbol-value (mal-seq-value (cadr a)))) + (body (caddr a))) + (mal-func + (lambda (&rest args) + (EVAL body (mal-env env binds args))) + body binds env))) (t ;; not a special form - (let ((fn* (mal-value (EVAL (car a) env))) - (args (mapcar (lambda (x) (EVAL x env)) (cdr a)))) - (apply fn* args)))) - ast))) - (symbol - (let ((key (mal-value ast))) - (or (mal-env-get env key) - (error "'%s' not found" key)))) - (vector - (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) - (mal-value ast))))) - (map - (let ((map (copy-hash-table (mal-value ast)))) + (let ((fn (EVAL (car a) env)) + (args (cdr a)) + fn*) + (cond + ((mal-func-value fn) + (EVAL (mal-func-body fn) + (mal-env (mal-func-env fn) + (mal-func-params fn) + (mapcar (lambda (x) (EVAL x env)) args)))) + ((setq fn* (mal-fn-core-value fn)) + ;; built-in function + (apply fn* (mapcar (lambda (x) (EVAL x env)) args))) + (t (error "cannot apply %s" (PRINT ast)))))))) + ((setq a (mal-symbol-value ast)) + (or (mal-env-get env a) (error "'%s' not found" a))) + ((setq a (mal-vector-value ast)) + (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) a)))) + ((setq a (mal-map-value ast)) + (let ((map (copy-hash-table a))) (maphash (lambda (key val) (puthash key (EVAL val env) map)) map) (mal-map map))) (t ;; return as is - ast))) + ast)))) (defun PRINT (input) (pr-str input t)) -(defun rep (input) +(defun rep (input repl-env) (PRINT (EVAL (READ input) repl-env))) -(rep "(def! not (fn* (a) (if a false true)))") - (defun readln (prompt) ;; C-d throws an error (ignore-errors (read-from-minibuffer prompt))) (defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) + (princ (if args + (apply 'format format-string args) + format-string)) (terpri)) +(defmacro with-error-handling (&rest body) + `(condition-case err + (progn ,@body) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err))))) + (defun main () - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (condition-case err - (println (rep input)) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err)))) - (setq eof t) - ;; print final newline - (terpri)))))) + (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)))) + + (rep "(def! not (fn* (a) (if a false true)))" repl-env) + + (let (input) + (while (setq input (readln "user> ")) + (with-error-handling + (println (rep input repl-env)))) + ;; print final newline + (terpri))) (main) diff --git a/impls/elisp/step5_tco.el b/impls/elisp/step5_tco.el index 2acffcff0d..b2b121acda 100644 --- a/impls/elisp/step5_tco.el +++ b/impls/elisp/step5_tco.el @@ -1,150 +1,146 @@ ;; -*- lexical-binding: t; -*- -(setq debug-on-error t) +(require 'cl-lib) (require 'mal/types) -(require 'mal/func) (require 'mal/env) (require 'mal/reader) (require 'mal/printer) (require 'mal/core) -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - (defun READ (input) (read-str input)) (defun EVAL (ast env) - (catch 'return - (while t + (let (return a) + (while (not return) (let ((dbgeval (mal-env-get env 'DEBUG-EVAL))) - (if (and dbgeval - (not (member (mal-type dbgeval) '(false nil)))) + (if (not (memq dbgeval (list nil mal-nil mal-false))) (println "EVAL: %s\n" (PRINT ast)))) - (cl-case (mal-type ast) - - (list - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (unless a (throw 'return ast)) - (cl-case (mal-value (car a)) - (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (throw 'return (mal-env-set env identifier value)))) - (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) - (setq env env* - ast form))) ; TCO - (do - (let* ((a0... (cdr a)) - (butlast (butlast a0...)) - (last (car (last a0...)))) - (mapcar (lambda (item) (EVAL item env)) butlast) - (setq ast last))) ; TCO - (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (setq ast then) ; TCO - (if else - (setq ast else) ; TCO - (throw 'return mal-nil))))) - (fn* - (let* ((binds (mapcar 'mal-value (mal-value a1))) - (body a2) - (fn (mal-fn - (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) - (throw 'return (mal-func body binds env fn)))) - (t - ;; not a special form - (let ((fn (EVAL (car a) env)) - (args (mapcar (lambda (x) (EVAL x env)) (cdr a)))) - (if (mal-func-p fn) - (let ((env* (mal-env (mal-func-env fn) - (mal-func-params fn) - args))) - (setq env env* - ast (mal-func-ast fn))) ; TCO - ;; built-in function - (let ((fn* (mal-value fn))) - (throw 'return (apply fn* args))))))))) - (symbol - (let ((key (mal-value ast))) - (throw 'return (or (mal-env-get env key) - (error "'%s' not found" key))))) - (vector - (throw 'return + (cond + + ((setq a (mal-list-value ast)) + (cl-case (mal-symbol-value (car a)) + (def! + (let ((identifier (mal-symbol-value (cadr a))) + (value (EVAL (caddr a) env))) + (setq return (mal-env-set env identifier value)))) + (let* + (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) + (setq env env* + ast form))) ; TCO + (do + (setq a (cdr a)) ; skip 'do + (while (cdr a) + (EVAL (pop a) env)) + (setq ast (car a))) ; TCO + (if + (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 + (fn* + (let ((binds (mapcar 'mal-symbol-value (mal-seq-value (cadr a)))) + (body (caddr a))) + (setq return (mal-func + (lambda (&rest args) + (EVAL body (mal-env env binds args))) + body binds env)))) + (t + ;; not a special form + (let ((fn (EVAL (car a) env)) + (args (cdr a)) + fn*) + (cond + ((mal-func-value fn) + (setq env (mal-env (mal-func-env fn) + (mal-func-params fn) + (mapcar (lambda (x) (EVAL x env)) args)) + ast (mal-func-body fn))) ; TCO + ((setq fn* (mal-fn-core-value fn)) + ;; built-in function + (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 (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) - (mal-value ast)))))) - (map - (let ((map (copy-hash-table (mal-value ast)))) + a))))) + ((setq a (mal-map-value ast)) + (let ((map (copy-hash-table a))) (maphash (lambda (key val) (puthash key (EVAL val env) map)) map) - (throw 'return (mal-map map)))) + (setq return (mal-map map)))) (t ;; return as is - (throw 'return ast)))))) + (setq return ast)))) + + ;; End of the TCO loop + return)) (defun PRINT (input) (pr-str input t)) -(defun rep (input) +(defun rep (input repl-env) (PRINT (EVAL (READ input) repl-env))) -(rep "(def! not (fn* (a) (if a false true)))") - (defun readln (prompt) ;; C-d throws an error (ignore-errors (read-from-minibuffer prompt))) (defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) + (princ (if args + (apply 'format format-string args) + format-string)) (terpri)) +(defmacro with-error-handling (&rest body) + `(condition-case err + (progn ,@body) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err))))) + (defun main () - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (condition-case err - (println (rep input)) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err)))) - (setq eof t) - ;; print final newline - (terpri)))))) + (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)))) + + (rep "(def! not (fn* (a) (if a false true)))" repl-env) + + (let (input) + (while (setq input (readln "user> ")) + (with-error-handling + (println (rep input repl-env)))) + ;; print final newline + (terpri))) (main) diff --git a/impls/elisp/step6_file.el b/impls/elisp/step6_file.el index 4c4ea269b8..9ba8b9c3c3 100644 --- a/impls/elisp/step6_file.el +++ b/impls/elisp/step6_file.el @@ -1,130 +1,113 @@ ;; -*- lexical-binding: t; -*- +(require 'cl-lib) (require 'mal/types) -(require 'mal/func) (require 'mal/env) (require 'mal/reader) (require 'mal/printer) (require 'mal/core) -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - (defun READ (input) (read-str input)) (defun EVAL (ast env) - (catch 'return - (while t + (let (return a) + (while (not return) (let ((dbgeval (mal-env-get env 'DEBUG-EVAL))) - (if (and dbgeval - (not (member (mal-type dbgeval) '(false nil)))) + (if (not (memq dbgeval (list nil mal-nil mal-false))) (println "EVAL: %s\n" (PRINT ast)))) - (cl-case (mal-type ast) - - (list - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (unless a (throw 'return ast)) - (cl-case (mal-value (car a)) - (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (throw 'return (mal-env-set env identifier value)))) - (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) - (setq env env* - ast form))) ; TCO - (do - (let* ((a0... (cdr a)) - (butlast (butlast a0...)) - (last (car (last a0...)))) - (mapcar (lambda (item) (EVAL item env)) butlast) - (setq ast last))) ; TCO - (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (setq ast then) ; TCO - (if else - (setq ast else) ; TCO - (throw 'return mal-nil))))) - (fn* - (let* ((binds (mapcar 'mal-value (mal-value a1))) - (body a2) - (fn (mal-fn - (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) - (throw 'return (mal-func body binds env fn)))) - (t - ;; not a special form - (let ((fn (EVAL (car a) env)) - (args (mapcar (lambda (x) (EVAL x env)) (cdr a)))) - (if (mal-func-p fn) - (let ((env* (mal-env (mal-func-env fn) - (mal-func-params fn) - args))) - (setq env env* - ast (mal-func-ast fn))) ; TCO - ;; built-in function - (let ((fn* (mal-value fn))) - (throw 'return (apply fn* args))))))))) - (symbol - (let ((key (mal-value ast))) - (throw 'return (or (mal-env-get env key) - (error "'%s' not found" key))))) - (vector - (throw 'return + (cond + + ((setq a (mal-list-value ast)) + (cl-case (mal-symbol-value (car a)) + (def! + (let ((identifier (mal-symbol-value (cadr a))) + (value (EVAL (caddr a) env))) + (setq return (mal-env-set env identifier value)))) + (let* + (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) + (setq env env* + ast form))) ; TCO + (do + (setq a (cdr a)) ; skip 'do + (while (cdr a) + (EVAL (pop a) env)) + (setq ast (car a))) ; TCO + (if + (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 + (fn* + (let ((binds (mapcar 'mal-symbol-value (mal-seq-value (cadr a)))) + (body (caddr a))) + (setq return (mal-func + (lambda (&rest args) + (EVAL body (mal-env env binds args))) + body binds env)))) + (t + ;; not a special form + (let ((fn (EVAL (car a) env)) + (args (cdr a)) + fn*) + (cond + ((mal-func-value fn) + (setq env (mal-env (mal-func-env fn) + (mal-func-params fn) + (mapcar (lambda (x) (EVAL x env)) args)) + ast (mal-func-body fn))) ; TCO + ((setq fn* (mal-fn-core-value fn)) + ;; built-in function + (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 (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) - (mal-value ast)))))) - (map - (let ((map (copy-hash-table (mal-value ast)))) + a))))) + ((setq a (mal-map-value ast)) + (let ((map (copy-hash-table a))) (maphash (lambda (key val) (puthash key (EVAL val env) map)) map) - (throw 'return (mal-map map)))) + (setq return (mal-map map)))) (t ;; return as is - (throw 'return ast)))))) + (setq return ast)))) -(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) -(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) + ;; End of the TCO loop + return)) (defun PRINT (input) (pr-str input t)) -(defun rep (input) +(defun rep (input repl-env) (PRINT (EVAL (READ input) repl-env))) -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - (defun readln (prompt) ;; C-d throws an error (ignore-errors (read-from-minibuffer prompt))) (defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) + (princ (if args + (apply 'format format-string args) + format-string)) (terpri)) (defmacro with-error-handling (&rest body) @@ -144,17 +127,28 @@ (println (error-message-string err))))) (defun main () + (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) + (if argv (with-error-handling - (rep (format "(load-file \"%s\")" (car argv)))) - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input + (rep (format "(load-file \"%s\")" (car argv)) repl-env)) + (let (input) + (while (setq input (readln "user> ")) (with-error-handling - (println (rep input))) - (setq eof t) - ;; print final newline - (terpri))))))) + (println (rep input repl-env)))) + ;; print final newline + (terpri)))) (main) diff --git a/impls/elisp/step7_quote.el b/impls/elisp/step7_quote.el index 4ec792c137..9bf20f7a11 100644 --- a/impls/elisp/step7_quote.el +++ b/impls/elisp/step7_quote.el @@ -2,159 +2,140 @@ (require 'cl-lib) (require 'mal/types) -(require 'mal/func) (require 'mal/env) (require 'mal/reader) (require 'mal/printer) (require 'mal/core) -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - -(defun starts-with-p (ast sym) - (let ((l (mal-value ast))) - (and l - (let ((s (car l))) - (and (mal-symbol-p s) - (eq (mal-value s) sym)))))) - (defun qq-reducer (elt acc) - (mal-list (if (and (mal-list-p elt) - (starts-with-p elt 'splice-unquote)) - (list (mal-symbol 'concat) (cadr (mal-value elt)) acc) - (list (mal-symbol 'cons) (quasiquote elt) acc)))) + (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))))) (defun qq-iter (elts) (cl-reduce 'qq-reducer elts :from-end t :initial-value (mal-list nil))) (defun quasiquote (ast) - (cl-case (mal-type ast) - (list (if (starts-with-p ast 'unquote) - (cadr (mal-value ast)) - (qq-iter (mal-value ast)))) - (vector (mal-list (list (mal-symbol 'vec) (qq-iter (mal-value ast))))) - ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) - (t ast))) + (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)))) (defun READ (input) (read-str input)) (defun EVAL (ast env) - (catch 'return - (while t + (let (return a) + (while (not return) (let ((dbgeval (mal-env-get env 'DEBUG-EVAL))) - (if (and dbgeval - (not (member (mal-type dbgeval) '(false nil)))) + (if (not (memq dbgeval (list nil mal-nil mal-false))) (println "EVAL: %s\n" (PRINT ast)))) - (cl-case (mal-type ast) - - (list - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (unless a (throw 'return ast)) - (cl-case (mal-value (car a)) - (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (throw 'return (mal-env-set env identifier value)))) - (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) - (setq env env* - ast form))) ; TCO - (quote - (throw 'return a1)) - (quasiquote - (setq ast (quasiquote a1))) ; TCO - (do - (let* ((a0... (cdr a)) - (butlast (butlast a0...)) - (last (car (last a0...)))) - (mapcar (lambda (item) (EVAL item env)) butlast) - (setq ast last))) ; TCO - (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (setq ast then) ; TCO - (if else - (setq ast else) ; TCO - (throw 'return mal-nil))))) - (fn* - (let* ((binds (mapcar 'mal-value (mal-value a1))) - (body a2) - (fn (mal-fn - (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) - (throw 'return (mal-func body binds env fn)))) - (t - ;; not a special form - (let ((fn (EVAL (car a) env)) - (args (mapcar (lambda (x) (EVAL x env)) (cdr a)))) - (if (mal-func-p fn) - (let ((env* (mal-env (mal-func-env fn) - (mal-func-params fn) - args))) - (setq env env* - ast (mal-func-ast fn))) ; TCO - ;; built-in function - (let ((fn* (mal-value fn))) - (throw 'return (apply fn* args))))))))) - (symbol - (let ((key (mal-value ast))) - (throw 'return (or (mal-env-get env key) - (error "'%s' not found" key))))) - (vector - (throw 'return + (cond + + ((setq a (mal-list-value ast)) + (cl-case (mal-symbol-value (car a)) + (def! + (let ((identifier (mal-symbol-value (cadr a))) + (value (EVAL (caddr a) env))) + (setq return (mal-env-set env identifier value)))) + (let* + (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) + (setq env env* + ast form))) ; TCO + (quote + (setq return (cadr a))) + (quasiquote + (setq ast (quasiquote (cadr a)))) ; TCO + (do + (setq a (cdr a)) ; skip 'do + (while (cdr a) + (EVAL (pop a) env)) + (setq ast (car a))) ; TCO + (if + (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 + (fn* + (let ((binds (mapcar 'mal-symbol-value (mal-seq-value (cadr a)))) + (body (caddr a))) + (setq return (mal-func + (lambda (&rest args) + (EVAL body (mal-env env binds args))) + body binds env)))) + (t + ;; not a special form + (let ((fn (EVAL (car a) env)) + (args (cdr a)) + fn*) + (cond + ((mal-func-value fn) + (setq env (mal-env (mal-func-env fn) + (mal-func-params fn) + (mapcar (lambda (x) (EVAL x env)) args)) + ast (mal-func-body fn))) ; TCO + ((setq fn* (mal-fn-core-value fn)) + ;; built-in function + (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 (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) - (mal-value ast)))))) - (map - (let ((map (copy-hash-table (mal-value ast)))) + a))))) + ((setq a (mal-map-value ast)) + (let ((map (copy-hash-table a))) (maphash (lambda (key val) (puthash key (EVAL val env) map)) map) - (throw 'return (mal-map map)))) + (setq return (mal-map map)))) (t ;; return as is - (throw 'return ast)))))) + (setq return ast)))) -(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) -(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) + ;; End of the TCO loop + return)) (defun PRINT (input) (pr-str input t)) -(defun rep (input) +(defun rep (input repl-env) (PRINT (EVAL (READ input) repl-env))) -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - (defun readln (prompt) ;; C-d throws an error (ignore-errors (read-from-minibuffer prompt))) (defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) + (princ (if args + (apply 'format format-string args) + format-string)) (terpri)) (defmacro with-error-handling (&rest body) @@ -174,17 +155,28 @@ (println (error-message-string err))))) (defun main () + (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) + (if argv (with-error-handling - (rep (format "(load-file \"%s\")" (car argv)))) - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input + (rep (format "(load-file \"%s\")" (car argv)) repl-env)) + (let (input) + (while (setq input (readln "user> ")) (with-error-handling - (println (rep input))) - (setq eof t) - ;; print final newline - (terpri))))))) + (println (rep input repl-env)))) + ;; print final newline + (terpri)))) (main) diff --git a/impls/elisp/step8_macros.el b/impls/elisp/step8_macros.el index 04c442dbcb..7d63ef624e 100644 --- a/impls/elisp/step8_macros.el +++ b/impls/elisp/step8_macros.el @@ -2,167 +2,146 @@ (require 'cl-lib) (require 'mal/types) -(require 'mal/func) (require 'mal/env) (require 'mal/reader) (require 'mal/printer) (require 'mal/core) -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - -(defun starts-with-p (ast sym) - (let ((l (mal-value ast))) - (and l - (let ((s (car l))) - (and (mal-symbol-p s) - (eq (mal-value s) sym)))))) - (defun qq-reducer (elt acc) - (mal-list (if (and (mal-list-p elt) - (starts-with-p elt 'splice-unquote)) - (list (mal-symbol 'concat) (cadr (mal-value elt)) acc) - (list (mal-symbol 'cons) (quasiquote elt) acc)))) + (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))))) (defun qq-iter (elts) (cl-reduce 'qq-reducer elts :from-end t :initial-value (mal-list nil))) (defun quasiquote (ast) - (cl-case (mal-type ast) - (list (if (starts-with-p ast 'unquote) - (cadr (mal-value ast)) - (qq-iter (mal-value ast)))) - (vector (mal-list (list (mal-symbol 'vec) (qq-iter (mal-value ast))))) - ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) - (t ast))) + (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)))) (defun READ (input) (read-str input)) (defun EVAL (ast env) - (catch 'return - (while t + (let (return a) + (while (not return) (let ((dbgeval (mal-env-get env 'DEBUG-EVAL))) - (if (and dbgeval - (not (member (mal-type dbgeval) '(false nil)))) + (if (not (memq dbgeval (list nil mal-nil mal-false))) (println "EVAL: %s\n" (PRINT ast)))) - (cl-case (mal-type ast) + (cond - (list - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (unless a (throw 'return ast)) - (cl-case (mal-value (car a)) + ((setq a (mal-list-value ast)) + (cl-case (mal-symbol-value (car a)) (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (throw 'return (mal-env-set env identifier value)))) + (let ((identifier (mal-symbol-value (cadr a))) + (value (EVAL (caddr a) env))) + (setq return (mal-env-set env identifier value)))) (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) + (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) (setq env env* ast form))) ; TCO (quote - (throw 'return a1)) + (setq return (cadr a))) (quasiquote - (setq ast (quasiquote a1))) ; TCO + (setq ast (quasiquote (cadr a)))) ; TCO (defmacro! - (let ((identifier (mal-value a1)) - (value (mal-macro (EVAL a2 env)))) - (throw 'return (mal-env-set env identifier value)))) + (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)))) (do - (let* ((a0... (cdr a)) - (butlast (butlast a0...)) - (last (car (last a0...)))) - (mapcar (lambda (item) (EVAL item env)) butlast) - (setq ast last))) ; TCO + (setq a (cdr a)) ; skip 'do + (while (cdr a) + (EVAL (pop a) env)) + (setq ast (car a))) ; TCO (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (setq ast then) ; TCO - (if else - (setq ast else) ; TCO - (throw 'return mal-nil))))) + (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 (fn* - (let* ((binds (mapcar 'mal-value (mal-value a1))) - (body a2) - (fn (mal-fn + (let ((binds (mapcar 'mal-symbol-value (mal-seq-value (cadr a)))) + (body (caddr a))) + (setq return (mal-func (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) - (throw 'return (mal-func body binds env fn)))) + (EVAL body (mal-env env binds args))) + body binds env)))) (t ;; not a special form (let ((fn (EVAL (car a) env)) - (args (cdr a))) - (if (mal-func-p fn) - (if (mal-func-macro-p fn) - (setq ast (apply (mal-value (mal-func-fn fn)) args)) ; TCO - (let ((env* (mal-env (mal-func-env fn) + (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) (mal-func-params fn) - (mapcar (lambda (x) (EVAL x env)) args)))) - (setq env env* - ast (mal-func-ast fn)))) ; TCO + (mapcar (lambda (x) (EVAL x env)) args)) + ast (mal-func-body fn))) ; TCO + ((setq fn* (mal-fn-core-value fn)) ;; built-in function - (let ((fn* (mal-value fn))) - (throw 'return (apply fn* (mapcar (lambda (x) (EVAL x env)) - args)))))))))) - (symbol - (let ((key (mal-value ast))) - (throw 'return (or (mal-env-get env key) - (error "'%s' not found" key))))) - (vector - (throw 'return + (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 (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) - (mal-value ast)))))) - (map - (let ((map (copy-hash-table (mal-value ast)))) + a))))) + ((setq a (mal-map-value ast)) + (let ((map (copy-hash-table a))) (maphash (lambda (key val) (puthash key (EVAL val env) map)) map) - (throw 'return (mal-map map)))) + (setq return (mal-map map)))) (t ;; return as is - (throw 'return ast)))))) + (setq return ast)))) -(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) -(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) + ;; End of the TCO loop + return)) (defun PRINT (input) (pr-str input t)) -(defun rep (input) +(defun rep (input repl-env) (PRINT (EVAL (READ input) repl-env))) -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - (defun readln (prompt) ;; C-d throws an error (ignore-errors (read-from-minibuffer prompt))) (defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) + (princ (if args + (apply 'format format-string args) + format-string)) (terpri)) (defmacro with-error-handling (&rest body) @@ -182,17 +161,31 @@ (println (error-message-string err))))) (defun main () + (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) + (if argv (with-error-handling - (rep (format "(load-file \"%s\")" (car argv)))) - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input + (rep (format "(load-file \"%s\")" (car argv)) repl-env)) + (let (input) + (while (setq input (readln "user> ")) (with-error-handling - (println (rep input))) - (setq eof t) - ;; print final newline - (terpri))))))) + (println (rep input repl-env)))) + ;; print final newline + (terpri)))) (main) diff --git a/impls/elisp/step9_try.el b/impls/elisp/step9_try.el index b381dd4070..2677282d1d 100644 --- a/impls/elisp/step9_try.el +++ b/impls/elisp/step9_try.el @@ -2,183 +2,164 @@ (require 'cl-lib) (require 'mal/types) -(require 'mal/func) (require 'mal/env) (require 'mal/reader) (require 'mal/printer) (require 'mal/core) -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - -(defun starts-with-p (ast sym) - (let ((l (mal-value ast))) - (and l - (let ((s (car l))) - (and (mal-symbol-p s) - (eq (mal-value s) sym)))))) - (defun qq-reducer (elt acc) - (mal-list (if (and (mal-list-p elt) - (starts-with-p elt 'splice-unquote)) - (list (mal-symbol 'concat) (cadr (mal-value elt)) acc) - (list (mal-symbol 'cons) (quasiquote elt) acc)))) + (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))))) (defun qq-iter (elts) (cl-reduce 'qq-reducer elts :from-end t :initial-value (mal-list nil))) (defun quasiquote (ast) - (cl-case (mal-type ast) - (list (if (starts-with-p ast 'unquote) - (cadr (mal-value ast)) - (qq-iter (mal-value ast)))) - (vector (mal-list (list (mal-symbol 'vec) (qq-iter (mal-value ast))))) - ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) - (t ast))) + (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)))) (defun READ (input) (read-str input)) (defun EVAL (ast env) - (catch 'return - (while t + (let (return a) + (while (not return) (let ((dbgeval (mal-env-get env 'DEBUG-EVAL))) - (if (and dbgeval - (not (member (mal-type dbgeval) '(false nil)))) + (if (not (memq dbgeval (list nil mal-nil mal-false))) (println "EVAL: %s\n" (PRINT ast)))) - (cl-case (mal-type ast) + (cond - (list - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (unless a (throw 'return ast)) - (cl-case (mal-value (car a)) + ((setq a (mal-list-value ast)) + (cl-case (mal-symbol-value (car a)) (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (throw 'return (mal-env-set env identifier value)))) + (let ((identifier (mal-symbol-value (cadr a))) + (value (EVAL (caddr a) env))) + (setq return (mal-env-set env identifier value)))) (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) + (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) (setq env env* ast form))) ; TCO (quote - (throw 'return a1)) + (setq return (cadr a))) (quasiquote - (setq ast (quasiquote a1))) ; TCO + (setq ast (quasiquote (cadr a)))) ; TCO (defmacro! - (let ((identifier (mal-value a1)) - (value (mal-macro (EVAL a2 env)))) - (throw 'return (mal-env-set env identifier value)))) + (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)))) (try* + (if (cddr a) (condition-case err - (throw 'return (EVAL a1 env)) + (setq return (EVAL (cadr a) env)) (error - (if (and a2 (eq (mal-value (car (mal-value a2))) 'catch*)) - (let* ((a2* (mal-value a2)) - (identifier (mal-value (cadr a2*))) - (form (nth 2 a2*)) + (let* ((a2* (mal-list-value (caddr a))) + (identifier (mal-symbol-value (cadr a2*))) + (form (caddr a2*)) (err* (if (eq (car err) 'mal-custom) ;; throw (cadr err) ;; normal error (mal-string (error-message-string err)))) - (env* (mal-env env (list identifier) (list err*)))) - (throw 'return (EVAL form env*))) - (signal (car err) (cdr err)))))) + (env* (mal-env env))) + (mal-env-set env* identifier err*) + (setq env env* + ast form)))) ; TCO + (setq ast (cadr a)))) ; TCO (do - (let* ((a0... (cdr a)) - (butlast (butlast a0...)) - (last (car (last a0...)))) - (mapcar (lambda (item) (EVAL item env)) butlast) - (setq ast last))) ; TCO + (setq a (cdr a)) ; skip 'do + (while (cdr a) + (EVAL (pop a) env)) + (setq ast (car a))) ; TCO (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (setq ast then) ; TCO - (if else - (setq ast else) ; TCO - (throw 'return mal-nil))))) + (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 (fn* - (let* ((binds (mapcar 'mal-value (mal-value a1))) - (body a2) - (fn (mal-fn + (let ((binds (mapcar 'mal-symbol-value (mal-seq-value (cadr a)))) + (body (caddr a))) + (setq return (mal-func (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) - (throw 'return (mal-func body binds env fn)))) + (EVAL body (mal-env env binds args))) + body binds env)))) (t ;; not a special form (let ((fn (EVAL (car a) env)) - (args (cdr a))) - (if (mal-func-p fn) - (if (mal-func-macro-p fn) - (setq ast (apply (mal-value (mal-func-fn fn)) args)) ; TCO - (let ((env* (mal-env (mal-func-env fn) + (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) (mal-func-params fn) - (mapcar (lambda (x) (EVAL x env)) args)))) - (setq env env* - ast (mal-func-ast fn)))) ; TCO + (mapcar (lambda (x) (EVAL x env)) args)) + ast (mal-func-body fn))) ; TCO + ((setq fn* (mal-fn-core-value fn)) ;; built-in function - (let ((fn* (mal-value fn))) - (throw 'return (apply fn* (mapcar (lambda (x) (EVAL x env)) - args)))))))))) - (symbol - (let ((key (mal-value ast))) - (throw 'return (or (mal-env-get env key) - (error "'%s' not found" key))))) - (vector - (throw 'return + (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 (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) - (mal-value ast)))))) - (map - (let ((map (copy-hash-table (mal-value ast)))) + a))))) + ((setq a (mal-map-value ast)) + (let ((map (copy-hash-table a))) (maphash (lambda (key val) (puthash key (EVAL val env) map)) map) - (throw 'return (mal-map map)))) + (setq return (mal-map map)))) (t ;; return as is - (throw 'return ast)))))) + (setq return ast)))) -(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) -(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) + ;; End of the TCO loop + return)) (defun PRINT (input) (pr-str input t)) -(defun rep (input) +(defun rep (input repl-env) (PRINT (EVAL (READ input) repl-env))) -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - (defun readln (prompt) ;; C-d throws an error (ignore-errors (read-from-minibuffer prompt))) (defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) + (princ (if args + (apply 'format format-string args) + format-string)) (terpri)) (defmacro with-error-handling (&rest body) @@ -198,17 +179,31 @@ (println (error-message-string err))))) (defun main () + (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) + (if argv (with-error-handling - (rep (format "(load-file \"%s\")" (car argv)))) - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input + (rep (format "(load-file \"%s\")" (car argv)) repl-env)) + (let (input) + (while (setq input (readln "user> ")) (with-error-handling - (println (rep input))) - (setq eof t) - ;; print final newline - (terpri))))))) + (println (rep input repl-env)))) + ;; print final newline + (terpri)))) (main) diff --git a/impls/elisp/stepA_mal.el b/impls/elisp/stepA_mal.el index 5ceb4d6dcd..534471f530 100644 --- a/impls/elisp/stepA_mal.el +++ b/impls/elisp/stepA_mal.el @@ -2,184 +2,164 @@ (require 'cl-lib) (require 'mal/types) -(require 'mal/func) (require 'mal/env) (require 'mal/reader) (require 'mal/printer) (require 'mal/core) -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - -(defun starts-with-p (ast sym) - (let ((l (mal-value ast))) - (and l - (let ((s (car l))) - (and (mal-symbol-p s) - (eq (mal-value s) sym)))))) - (defun qq-reducer (elt acc) - (mal-list (if (and (mal-list-p elt) - (starts-with-p elt 'splice-unquote)) - (list (mal-symbol 'concat) (cadr (mal-value elt)) acc) - (list (mal-symbol 'cons) (quasiquote elt) acc)))) + (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))))) (defun qq-iter (elts) (cl-reduce 'qq-reducer elts :from-end t :initial-value (mal-list nil))) (defun quasiquote (ast) - (cl-case (mal-type ast) - (list (if (starts-with-p ast 'unquote) - (cadr (mal-value ast)) - (qq-iter (mal-value ast)))) - (vector (mal-list (list (mal-symbol 'vec) (qq-iter (mal-value ast))))) - ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) - (t ast))) + (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)))) (defun READ (input) (read-str input)) (defun EVAL (ast env) - (catch 'return - (while t + (let (return a) + (while (not return) (let ((dbgeval (mal-env-get env 'DEBUG-EVAL))) - (if (and dbgeval - (not (member (mal-type dbgeval) '(false nil)))) + (if (not (memq dbgeval (list nil mal-nil mal-false))) (println "EVAL: %s\n" (PRINT ast)))) - (cl-case (mal-type ast) + (cond - (list - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (unless a (throw 'return ast)) - (cl-case (mal-value (car a)) + ((setq a (mal-list-value ast)) + (cl-case (mal-symbol-value (car a)) (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (throw 'return (mal-env-set env identifier value)))) + (let ((identifier (mal-symbol-value (cadr a))) + (value (EVAL (caddr a) env))) + (setq return (mal-env-set env identifier value)))) (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) + (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) (setq env env* ast form))) ; TCO (quote - (throw 'return a1)) + (setq return (cadr a))) (quasiquote - (setq ast (quasiquote a1))) ; TCO + (setq ast (quasiquote (cadr a)))) ; TCO (defmacro! - (let ((identifier (mal-value a1)) - (value (mal-macro (EVAL a2 env)))) - (throw 'return (mal-env-set env identifier value)))) + (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)))) (try* + (if (cddr a) (condition-case err - (throw 'return (EVAL a1 env)) + (setq return (EVAL (cadr a) env)) (error - (if (and a2 (eq (mal-value (car (mal-value a2))) 'catch*)) - (let* ((a2* (mal-value a2)) - (identifier (mal-value (cadr a2*))) - (form (nth 2 a2*)) + (let* ((a2* (mal-list-value (caddr a))) + (identifier (mal-symbol-value (cadr a2*))) + (form (caddr a2*)) (err* (if (eq (car err) 'mal-custom) ;; throw (cadr err) ;; normal error (mal-string (error-message-string err)))) - (env* (mal-env env (list identifier) (list err*)))) - (throw 'return (EVAL form env*))) - (signal (car err) (cdr err)))))) + (env* (mal-env env))) + (mal-env-set env* identifier err*) + (setq env env* + ast form)))) ; TCO + (setq ast (cadr a)))) ; TCO (do - (let* ((a0... (cdr a)) - (butlast (butlast a0...)) - (last (car (last a0...)))) - (mapcar (lambda (item) (EVAL item env)) butlast) - (setq ast last))) ; TCO + (setq a (cdr a)) ; skip 'do + (while (cdr a) + (EVAL (pop a) env)) + (setq ast (car a))) ; TCO (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (setq ast then) ; TCO - (if else - (setq ast else) ; TCO - (throw 'return mal-nil))))) + (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 (fn* - (let* ((binds (mapcar 'mal-value (mal-value a1))) - (body a2) - (fn (mal-fn + (let ((binds (mapcar 'mal-symbol-value (mal-seq-value (cadr a)))) + (body (caddr a))) + (setq return (mal-func (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) - (throw 'return (mal-func body binds env fn)))) + (EVAL body (mal-env env binds args))) + body binds env)))) (t ;; not a special form (let ((fn (EVAL (car a) env)) - (args (cdr a))) - (if (mal-func-p fn) - (if (mal-func-macro-p fn) - (setq ast (apply (mal-value (mal-func-fn fn)) args)) ; TCO - (let ((env* (mal-env (mal-func-env fn) + (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) (mal-func-params fn) - (mapcar (lambda (x) (EVAL x env)) args)))) - (setq env env* - ast (mal-func-ast fn)))) ; TCO + (mapcar (lambda (x) (EVAL x env)) args)) + ast (mal-func-body fn))) ; TCO + ((setq fn* (mal-fn-core-value fn)) ;; built-in function - (let ((fn* (mal-value fn))) - (throw 'return (apply fn* (mapcar (lambda (x) (EVAL x env)) - args)))))))))) - (symbol - (let ((key (mal-value ast))) - (throw 'return (or (mal-env-get env key) - (error "'%s' not found" key))))) - (vector - (throw 'return + (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 (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) - (mal-value ast)))))) - (map - (let ((map (copy-hash-table (mal-value ast)))) + a))))) + ((setq a (mal-map-value ast)) + (let ((map (copy-hash-table a))) (maphash (lambda (key val) (puthash key (EVAL val env) map)) map) - (throw 'return (mal-map map)))) + (setq return (mal-map map)))) (t ;; return as is - (throw 'return ast)))))) + (setq return ast)))) -(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) -(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) -(mal-env-set repl-env '*host-language* (mal-string "elisp")) + ;; End of the TCO loop + return)) (defun PRINT (input) (pr-str input t)) -(defun rep (input) +(defun rep (input repl-env) (PRINT (EVAL (READ input) repl-env))) -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - (defun readln (prompt) ;; C-d throws an error (ignore-errors (read-from-minibuffer prompt))) (defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) + (princ (if args + (apply 'format format-string args) + format-string)) (terpri)) (defmacro with-error-handling (&rest body) @@ -199,18 +179,33 @@ (println (error-message-string err))))) (defun main () + (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)))) + (mal-env-set repl-env '*host-language* (mal-string "elisp")) + + (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) + (if argv (with-error-handling - (rep (format "(load-file \"%s\")" (car argv)))) - (let (eof) - (rep "(println (str \"Mal [\" *host-language* \"]\"))") - (while (not eof) - (let ((input (readln "user> "))) - (if input + (rep (format "(load-file \"%s\")" (car argv)) repl-env)) + (let (input) + (rep "(println (str \"Mal [\" *host-language* \"]\"))" repl-env) + (while (setq input (readln "user> ")) (with-error-handling - (println (rep input))) - (setq eof t) - ;; print final newline - (terpri))))))) + (println (rep input repl-env)))) + ;; print final newline + (terpri)))) (main)