Plaster

(defun concatenate-and-intern (&rest objects) "Generate and intern a symbol based on the concatenation of the supplied objects." (intern (apply #'concatenate 'string (mapcar #'stringify objects)))) (defun concatenate-and-intern-keyword (&rest objects) "Generate and intern a keyword symbol based on the concatenation of the supplied objects." (intern (apply #'concatenate 'string (mapcar #'stringify objects)) "KEYWORD")) (defgeneric stringify (obj) (:documentation "Generate a string equivalent of OBJ.")) (defmethod stringify ((obj string)) obj) (defmethod stringify ((obj symbol)) (symbol-name obj)) ;;;;**************************************************************************** ;;; Generate Slot Forms for use in DEFINE-CLASS Macro ;;; Slots are either symbol or (symbol . initform) (defun define-class-inherited-slot-forms (class-name slots) "Returns a list of slot forms for use within the DEFINE-CLASS macro expression." (loop for slot in slots collect (typecase slot (atom (list (concatenate-and-intern "%" slot) :initarg (concatenate-and-intern-keyword slot) :accessor (concatenate-and-intern slot))) (list (list (concatenate-and-intern "%" (car slot)) :initarg (concatenate-and-intern (car slot)) :accessor (concatenate-and-intern (car slot)) :initform (concatenate-and-intern `',(cdr slot))))))) ;;;;**************************************************************************** ;;; NOT USED - BUT CAN BE (TESTED) ;; (defun define-class-primary-slot-forms (class-name) ;; "Returns a slot form for use within the DEFINE-CLASS macro expression for single-slot classes." ;; (list (list (concatenate-and-intern "%" class-name) ;; :initarg (concatenate-and-intern-keyword class-name) ;; :accessor (concatenate-and-intern class-name)))) ;;;;**************************************************************************** ;;; Modify Accessor Functions - NOT USED (BUT CAN BE (TESTED) ;; (defun define-class-reader-forms (class-name slots) ;; "Generate a DEFMETHOD form to re-point the reader for SLOT in CLASS-NAME to (SLOT (CLASS-NAME OBJ))." ;; (loop for slot in slots ;; collect ;; `(defmethod ,slot ((obj ,class-name)) ;; (,slot (,(concatenate-and-intern class-name "-" slot) obj))))) ;; (defun define-class-writer-forms (class-name slots) ;; "Generate a DEFMETHOD form to re-point the reader for SLOT in CLASS-NAME to (SLOT (CLASS-NAME OBJ))." ;; (loop for slot in slots ;; collect ;; `(defmethod (setf ,slot) (val (obj ,class-name)) ;; (setf (,(concatenate-and-intern class-name "-" slot) obj) val)))) ;;;;**************************************************************************** ;;; Primary Macro (defmacro define-class (class-name slots &rest options) "Defines a CLOS class for CLASS-NAME with SLOTS with SLOT NAME = %SLOT and ACCESSOR = SLOT." (let ((slot-forms (define-class-inherited-slot-forms class-name slots))) `(defclass ,class-name ,slots ,@slot-forms ,@options)))