diff options
Diffstat (limited to 'metaenv.lisp')
| -rw-r--r-- | metaenv.lisp | 308 |
1 files changed, 308 insertions, 0 deletions
diff --git a/metaenv.lisp b/metaenv.lisp new file mode 100644 index 0000000..151c197 --- /dev/null +++ b/metaenv.lisp @@ -0,0 +1,308 @@ +(in-package :agnostic-lizard) + +; basic metaenv class interface and NOP default implementations + +(defgeneric metaenv-function-like-entries (obj) + (:documentation + "Query the list of function-like entries from a metaenv object")) +(defgeneric metaenv-variable-like-entries (obj) + (:documentation + "Query the list of variable-like entries from a metaenv object")) +(defgeneric metaenv-blocks (obj) + (:documentation + "Query the list of defined blocks from a metaenv object")) +(defgeneric metaenv-tags (obj) + (:documentation + "Query the list of defined tags from a metaenv object")) +(defgeneric metaenv-fallback-env (obj) + (:documentation + "Query the fallback environment object from a metaenv object")) + +(defgeneric metaenv-add-function-like-entry (obj entry) + (:documentation + "Add a function-like entry into the metaenv object. +The entry should follow the format described in wrap-function-like-env. +The entry will shadow previously available entries with the same name.")) +(defgeneric metaenv-add-variable-like-entry (obj entry) + (:documentation + "Add a variable-like entry into the metaenv object. +The entry should follow the format described in wrap-variable-like-env. +The entry will shadow previously available entries with the same name." )) +(defgeneric metaenv-add-block (obj name) + (:documentation + "Add a block into the metaenv object.")) +(defgeneric metaenv-add-tag (obj name) + (:documentation + "Add a tag into the metaenv object.")) + +(defgeneric metaenv-clone-args (obj) + (:documentation + "The needed initargs for copying a metaenv-related object")) +(defgeneric metaenv-clone (obj &optional overrides) + (:documentation + "Create a copy of a metaenv-related object")) + +(defmethod metaenv-function-like-entries ((obj t))) +(defmethod metaenv-variable-like-entries ((obj t))) +(defmethod metaenv-blocks ((obj t))) +(defmethod metaenv-tags ((obj t))) +(defmethod metaenv-fallback-env ((obj t))) + +(defmethod metaenv-add-function-like-entry ((obj t) (entry t))) +(defmethod metaenv-add-variable-like-entry ((obj t) (entry t))) +(defmethod metaenv-add-block ((obj t) (name t))) +(defmethod metaenv-add-tag ((obj t) (name t))) + +; The interface is enough to define building a similar environment + +(defun metaenv-wrap-form (obj form) + "Wrap the form into environment-setting wrappers corresponding to all the entries of obj." + (let* + ((form form) + (form + (wrap-function-like-env + (metaenv-function-like-entries obj) form)) + (form + (wrap-variable-like-env + (metaenv-variable-like-entries obj) form)) + (form (wrap-block-env (metaenv-blocks obj) form)) + (form (wrap-tag-env (metaenv-tags obj) form))) + form)) + +(defun with-metaenv-built-env (obj var code) + "Evaluate code in the lexical environment where var is bound to the lexical environment object described by obj" + (eval + (metaenv-wrap-form + obj + `(eval-with-current-environment + (,var) ,@code)))) + +; The basic metaenv class and methods + +(defclass metaenv () + ((function-like + :initarg :function-like :initarg :func :initarg :fun :initarg :fn + :initform nil :accessor metaenv-function-like-entries) + (variable-like :initarg :variable-like :initarg :var :initform nil + :accessor metaenv-variable-like-entries) + (blocks :initarg :blocks :initarg :block :initform nil + :accessor metaenv-blocks) + (tags :initarg :tags :initarg :tag :initform nil :accessor metaenv-tags) + (fallback-env + :initarg :fallback-env :initarg :env :initform nil + :accessor metaenv-fallback-env + :documentation "A slot for storing environment obtained via an &environment parameter")) + (:documentation "The basic object holding the lexical environment data for macroexpansion")) + +(defmethod metaenv-add-function-like-entry ((obj metaenv) (entry t)) + (push entry (metaenv-function-like-entries obj))) +(defmethod metaenv-add-variable-like-entry ((obj metaenv) (entry t)) + (push entry (metaenv-variable-like-entries obj))) +(defmethod metaenv-add-block ((obj metaenv) (name t)) + (push name (metaenv-blocks obj))) +(defmethod metaenv-add-tag ((obj metaenv) (name t)) + (pushnew name (metaenv-tags obj))) + +(defmethod metaenv-clone-args ((obj metaenv)) + (list + :function-like (metaenv-function-like-entries obj) + :variable-like (metaenv-variable-like-entries obj) + :blocks (metaenv-blocks obj) + :tags (metaenv-tags obj) + :fallback-env (metaenv-fallback-env obj))) + +(defmethod metaenv-clone ((obj metaenv) &optional overrides) + (apply + 'make-instance 'metaenv + (append + overrides + (metaenv-clone-args obj)))) + +; A helper for output +(defmethod print-object ((obj metaenv) stream) + (format stream "#<~a:~{ ~S~}>" + (type-of obj) + (loop + for arg in (metaenv-clone-args obj) + collect + (cond + ((keywordp arg) arg) + ((symbolp arg) `',arg) + ((consp arg) `',arg) + (t arg))))) + +; A useful helper for expansions +(defun metaenv-irrelevant-for-macroexpand (obj) + "Check if the metaenv obj is the same as the fallback environment for macroexpand-1" + (and + (loop + with fbe := (metaenv-fallback-env obj) + with seen := (make-hash-table) + for fn in (metaenv-function-like-entries obj) + when (second fn) + unless (or + (gethash (first fn) seen) + (and + (eq (first (second fn)) :plain) + (null (macro-function (first fn) fbe)))) + return nil + do (setf (gethash (first fn) seen) t) + finally (return t)) + (loop + with fbe := (metaenv-fallback-env obj) + with seen := (make-hash-table) + for fn in (metaenv-variable-like-entries obj) + when (second fn) + unless (or + (gethash (first fn) seen) + (and + (eq (first (second fn)) :plain) + (eq (first fn) (macroexpand-1 (first fn) fbe)))) + return nil + do (setf (gethash (first fn) seen) t) + finally (return t)))) + +(defclass walker-metaenv (metaenv) + ((on-function-form :initform #'values :initarg :on-function-form + :accessor metaenv-on-function-form) + (on-function-form-pre + :initform #'values :initarg :on-function-form-pre + :accessor metaenv-on-function-form-pre) + (on-every-form :initform #'values :initarg :on-every-form + :accessor metaenv-on-every-form) + (on-every-form-pre :initform #'values :initarg :on-every-form-pre + :accessor metaenv-on-every-form-pre) + (on-special-form-pre :initform #'values :initarg :on-special-form-pre + :accessor metaenv-on-special-form-pre) + (on-special-form :initform #'values :initarg :on-special-form + :accessor metaenv-on-special-form) + (on-macroexpanded-form :initform #'values :initarg :on-macroexpanded-form + :accessor metaenv-on-macroexpanded-form)) + (:documentation "An extended walker environment object. +Here we keep a few handlers to allow transformations of the code during walking.")) + +(defmethod metaenv-clone-args :around ((obj walker-metaenv)) + (append + (call-next-method) + (list + :on-function-form (metaenv-on-function-form obj) + :on-function-form-pre (metaenv-on-function-form-pre obj) + :on-special-form (metaenv-on-special-form obj) + :on-special-form-pre (metaenv-on-special-form-pre obj) + :on-every-form (metaenv-on-every-form obj) + :on-every-form-pre (metaenv-on-every-form-pre obj) + :on-macroexpanded-form (metaenv-on-macroexpanded-form obj)))) + +(defmethod metaenv-clone ((obj walker-metaenv) &optional overrides) + (apply + 'make-instance 'walker-metaenv + (append + overrides + (metaenv-clone-args obj)))) + +(defclass macro-walker-metaenv (walker-metaenv) + ((create-macro + :initform t :initarg :create-macro + :accessor metaenv-create-macro + :documentation "Whether to do expansion or just create a macro call that will be able to get proper environment") + (recursive-label + :initform (gensym) :initarg :recursive-label + :accessor metaenv-recursive-label + :documentation + "A label to distinguish the forms freshly created in relation to the current environment.") + (on-macro-walker-create-macro + :initform 'values :initarg :on-macro-walker-create-macro + :accessor metaenv-on-macro-walker-create-macro + :documentation + "A handler invoked when macro-walker creates a new macro")) + (:documentation "A version of walker-metaenv that can store additional information for expanding to a form with macro calls. +This approach allows to use Common Lisp implementation's own handling of environment. +We still keep track of environment just for portable access to the list of discovered lexical environment entries.")) + +(defmethod metaenv-clone-args :around ((obj macro-walker-metaenv)) + (append + (call-next-method) + (list + :create-macro (metaenv-create-macro obj) + :recursive-label (metaenv-recursive-label obj) + :on-macro-walker-create-macro (metaenv-on-macro-walker-create-macro obj)))) + +(defmethod metaenv-clone ((obj macro-walker-metaenv) &optional overrides) + (apply + 'make-instance 'macro-walker-metaenv + (append + overrides + (metaenv-clone-args obj)))) + +(defmethod metaenv-recursive-label (obj) nil) + +(defmacro metaenv-macro-macroexpand-all (form &environment env &optional extra-env) + "A helper macro for recapturing environment" + (let* + ((envcopy (cond + ((null extra-env) (make-instance 'macro-walker-metaenv)) + ((consp extra-env) (eval extra-env)) + (t (metaenv-clone extra-env))))) + (setf (metaenv-create-macro envcopy) nil) + (setf (metaenv-fallback-env envcopy) env) + (metaenv-macroexpand-all form envcopy))) + +(defmacro metaenv-macro-macroexpand-all-wrapper (form env) + "This wrapper does nothing but protects form from metaenv-macro-walker-turn-to-quoted" + (declare (ignorable env)) + form) + +(defmethod metaenv-macroexpand-all :around (form (env macro-walker-metaenv)) + (if (metaenv-create-macro env) + (progn + `(metaenv-macro-macroexpand-all-wrapper + ,(funcall + (metaenv-on-macro-walker-create-macro env) + `(metaenv-macro-macroexpand-all ,form ,env) env) + ,env)) + (let* ((envcopy (metaenv-clone env))) + (setf (metaenv-create-macro envcopy) t) + (call-next-method form envcopy)))) + +(defmethod metaenv-macroexpand-1 (form (env macro-walker-metaenv)) + (macroexpand-1 form (metaenv-fallback-env env))) + +(defun metaenv-macro-walker-turn-to-quoted (form env &optional cdr-branch) + "Convert a partially walked form into code producing the expansion of the form after the walk is completed" + (cond + ((not (consp form)) `(quote ,form)) + ((and + (not cdr-branch) + (find (first form) + '(metaenv-macro-macroexpand-all-wrapper)) + (eq (metaenv-recursive-label (ignore-errors (third form))) + (metaenv-recursive-label env))) + form) + (t `(cons ,(metaenv-macro-walker-turn-to-quoted (car form) env) + ,(metaenv-macro-walker-turn-to-quoted (cdr form) env t))))) + +(defmacro macro-walk-form (form &rest handler-definitions) + "Walk the form inside the current lexical environment using the handlers from handler-definitions. +See walk-form for details about handlers. +The resulting form after walking is returned as the macroexpansion." + `(metaenv-macro-macroexpand-all + ,form + (make-instance 'macro-walker-metaenv + ,@ handler-definitions))) + +(defmacro macro-macroexpand-all (form &rest handler-definitions &key + (on-every-form ''values) + (on-macro-walker-create-macro ''values)) + "Produce code returning the full macroexpansion of the form in the current lexical environment. +Optionally, run handlers. :on-every-form will be run before quoting and wrapping in environment handling helpers." + `(macro-walk-form + ,form + :on-every-form (lambda (form env) + (metaenv-macro-walker-turn-to-quoted + (funcall ,on-every-form + form env) env)) + :on-macro-walker-create-macro + (lambda (form env) + (metaenv-wrap-form env + (funcall ,on-macro-walker-create-macro form env))) + ,@ handler-definitions)) |