| Paste number 36596: | Macro-generating macro |
| Pasted by: | pkhuong |
| 1 year, 10 months ago | |
| None | |
| Paste contents: |
| (defun subst-with (tree &key values (subst-fn (constantly nil))) "Walks the tree (conses), substituting leaves/subtrees as indicated by values [an alist] or subst-fn (Either nil element -> [subst-p subst-with]), in that order" (let ((entry (assoc tree values :test #'equal))) (if entry ; `=>' anyone? (cdr entry) (multiple-value-bind (subst-p new-value) (funcall subst-fn tree) (if subst-p new-value (if (consp tree) (cons (subst-with (car tree) :values values :subst-fn subst-fn) (subst-with (cdr tree) :values values :subst-fn subst-fn)) tree)))))) (defun arg-names (arg-list) "Extracts the argument names from a lambda list." (mapcan (lambda (arg) (unless (member arg lambda-list-keywords :test #'eq) (list (cond ((symbolp arg) arg) ((symbolp (car arg)) (car arg)) ((symbolp (second (car arg))) (second (car arg))) (t (error "Malformed argument ~A~%" arg)))))) arg-list)) (defun symbol-concat (package externalp &rest symbols) "Concatenates the symbols into a single symbol in package `package', and exports it if `externalp'" (let* ((symbol-name (apply #'concatenate 'string (mapcar (lambda (symbol) (if (stringp symbol) symbol (symbol-name symbol))) symbols))) (symbol (intern symbol-name package))) (when externalp (export (list symbol) package)) symbol)) (defun make-symbol-concat (externalp environment) "Given an environment (alist of var -> value), first returns a function that will substitute (:~ ...) with a single symbol." (lambda (expr) (when (and (listp expr) (eq (first expr) ':~)) (let* ((args (rest expr)) (package (if (eq (first args) :package) (prog1 (second args) (setf args (cddr args))) (symbol-package (first args)))) (symbol (intern (apply #'concatenate 'string (mapcar (lambda (arg) (cond ((stringp arg) arg) ((and (listp arg) (eq (first arg) 'quote)) (symbol-name (second arg))) (t (let ((entry (assoc arg environment))) (symbol-name (if entry (cdr entry) arg)))))) args)) package))) (when externalp (export (list symbol) package)) (values t symbol))))) (defmacro deftemplate (name (&rest arguments) (&key (external t) (compile-toplevel t) (load-toplevel t) (execute t)) &body templated) "Defines a templating macro. The arguments are replaced with their value in the template body" (let ((args (arg-names arguments))) `(defmacro ,name ,arguments (let ((environment (list ,@ (mapcar (lambda (arg) `(cons ',arg ,arg)) args)))) (list* 'eval-when '(,@ (when compile-toplevel '(:compile-toplevel)) ,@ (when load-toplevel '(:load-toplevel)) ,@ (when execute '(:execute))) (subst-with ',templated :values environment :subst-fn (make-symbol-concat ',external environment))))))) |
Annotations for this paste:
| Annotation number 1: | Example usage (contextfree snippet ;) |
| Pasted by: | pkhuong |
| 1 year, 10 months ago | |
| Paste contents: |
| (deftemplate ~vector (type-name &optional (type-spec type-name) &aux (base-name (symbol-concat '#:m t 'vec '- type-name)) (imm-name (symbol-concat '#:m t 'imm '- base-name)) (map-name (symbol-concat '#:m t 'map '- base-name))) () (defclass base-name (m:vector) ((element-type :accessor m:element-type :initform 'type-spec))) (defclass imm-name (base-name) ((content :accessor content-of :initarg :content))) (defun imm-name (value) (make-instance 'imm-name :length (length value) :content (make-array (length value) :element-type 'type-spec :initial-contents (coerce value 'list)))) (defmethod m:ref ((value imm-name) &rest indices) (aref (content-of value) (first indices))) (defmethod m:!ref ((value imm-name)) '(:before () :after () :extract content-of :ref aref)) (defclass map-name (base-name) ((input :accessor input-of :initarg :input) (fn :accessor fn-of :initarg :fn) (cfn :accessor cfn-of :initarg :cfn) (extract :accessor extract-of :initarg :extract) (cxt :accessor cxt-of :initarg :cxt))) (defun map-name (fn input) (destructuring-bind (&key before after extract ref) (m:!ref input) (let* ((_index (gensym "INDEX")) (_input (gensym "INPUT")) (fn `(lambda (,_input ,_index) (prog2 (progn ,@before) (,fn (,ref ,_input ,_index)) ,@after))) (extract `(lambda (,_input) ,(if extract `(,extract (input-of ,_input)) `(input-of ,_input))))) (make-instance 'map-name :input input :fn fn :cfn (compile nil fn) :extract extract :cxt (compile nil extract))))) (defmethod m:map (fn (input base-name)) (map-name fn input)) (defmethod m:ref ((value map-name) &rest indices) (funcall (cfn-of value) (funcall (cxt-of value) value) (first indices))) (defmethod m:!ref ((value map-name)) `(:extract ,(extract-of value) :ref ,(fn-of value))) ) (~vector double double-float) |