| Paste number 58367: | DEFINE-CONSTRUCTOR "complete" |
| Pasted by: | H4ns |
| 3 months, 3 weeks ago | |
| #lisp | Context in IRC logs | |
| Paste contents: |
| (defpackage :mop-tools (:use "CL" "ALEXANDRIA" "CLOSER-MOP")) (in-package :mop-tools) (defmacro define-constructor (class-name (&rest args) &body body) "Define a constructor for instances of class CLASS-NAME named MAKE-<CLASS-NAME>. The constructor that is being defined has an lambda list that contains all accepted initargs for the class in addition to any explicit constructor arguments defined. The class for which the constructor is being created must be defined at compile time. ARGS is the \(partial) argument list which will be extended by all initargs accepted by the class. In the BODY, the local function INVOKE-MAKE-INSTANCE is bound which will invoke MAKE-INSTANCE for the given class name with an argument list composed of three lists, in the following order. - The arguments given to INVOKE-MAKE-INSTANCE - Any keyword arguments that have been declared in the argument list for the constructor and that match a defined initarg of the class - All keyword arguments that have been supplied by the user and that match a defined initarg of the class. Due to the ordering, keyword arguments computed in the constructor override those that have been supplied by the user." (let ((class-name class-name) (args args) (body body)) (unless (find '&key args) (setf args (append args (list '&key)))) (let* ((class-initargs (nreverse (mapcar (compose #'intern #'symbol-name) (mappend #'slot-definition-initargs (class-slots (find-class class-name)))))) (function-args (mapcar (lambda (arg) (intern (symbol-name (if (listp arg) (car arg) arg)))) (remove-if (lambda (arg) (and (symbolp arg) (eql #\& (elt (symbol-name arg) 0)))) args))) (generated-args (set-difference class-initargs function-args)) (gensyms (mapcar (compose #'gensym #'symbol-name) generated-args)) (supplied-p-gensyms (mapcar (compose #'gensym #'symbol-name) generated-args))) `(defun ,(intern (format nil "MAKE-~A" class-name)) (,@args ,@(mapcar #'list generated-args (make-list (length generated-args)) supplied-p-gensyms)) (let ,(mapcar #'list gensyms generated-args) (flet ((invoke-make-instance (&rest args &key &allow-other-keys) (apply #'make-instance ',class-name (append args (list ,@(mappend (lambda (symbol) (list (intern (symbol-name symbol) :keyword) symbol)) (intersection class-initargs function-args))) (loop for argument in (list ,@gensyms) for argument-supplied-p in (list ,@supplied-p-gensyms) when argument-supplied-p collect (intern (symbol-name argument) :keyword) and collect argument))))) ,@body)))))) (define-constructor cl-mime:mime (content-type content) (destructuring-bind (content-type content-subtype) (cl-ppcre:split "/" content-type :limit 2) (invoke-make-instance :type content-type :subtype content-subtype :content content))) (define-constructor cl-mime:multipart-mime (parts &key (subtype "mixed")) (invoke-make-instance :subtype subtype :content parts)) |
This paste has no annotations.