Re: allowable specializers

[Christopher.McConnell@A.GP.CS.CMU.EDU]

Here is another way to allow writing methods on defstructs.  It should
work in any CL.  It works by adding defstructs to the built-in class
hierarchy.  It redefines defstruct, so that this automatically
happens.

;;;
(in-package 'pcl)

;;;
;;; This whole set of hair is from PCL's high.lisp.  Some day, it will be
;;; built into defstruct.  It allows you to define defstructs without
;;; much penalty, but the first time you call a generic function, it
;;; rebuilds the type wrappers, so it can take a while.
;;;
(defun make-built-in-class-subs ()
  (mapcar #'(lambda (e)
	      (let ((class (car e))
		    (class-subs ()))
		(dolist (s *built-in-classes*)
		  (when (memq class (cadr s)) (pushnew (car s) class-subs)))
		(cons class class-subs)))
	  (cons '(t) *built-in-classes*)))

(defun make-built-in-class-tree ()
  (let ((subs (make-built-in-class-subs)))
    (labels ((descend (class)
	       (cons class (mapcar #'descend (cdr (assq class subs))))))
      (descend 't))))

(defun make-built-in-wrapper-of-body ()
  (make-built-in-wrapper-of-body-1 (make-built-in-class-tree)
				   'x
				   #'get-built-in-wrapper-symbol))

(defun make-built-in-class-of-body ()
  (make-built-in-wrapper-of-body-1 (make-built-in-class-tree)
				   'x
				   #'get-built-in-class-symbol))


(defun make-built-in-wrapper-of-body-1 (tree var get-symbol)
  (let ((*specials* ()))
    (declare (special *specials*))
    (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol)))
      `(locally (declare (special .,*specials*)) ,inner))))

(defun make-built-in-wrapper-of-body-2 (tree var get-symbol)
  (declare (special *specials*))
  (let ((symbol (funcall get-symbol (car tree))))
    (push symbol *specials*)
    (let ((sub-tests
	    (mapcar #'(lambda (x)
			(make-built-in-wrapper-of-body-2 x var get-symbol))
		    (cdr tree))))
      `(and (typep ,var ',(car tree))
	    ,(if sub-tests
		 `(or ,.sub-tests ,symbol)
		 symbol)))))

;;;
(defun DEFINE-BUILT-IN-CLASS (name supers)
  "Define a new built in CLOS class.  Typically for structures."
  (let ((proto (class-prototype (find-class 'built-in-class))))
    (add-named-class proto name supers () ())
    (let ((class-symbol (get-built-in-class-symbol name))
	  (wrapper-symbol (get-built-in-wrapper-symbol name))
	  (class (find-class name))
	  (cell (or (assoc name *built-in-classes*)
		    (first (push (list name) *built-in-classes*)))))
      (set class-symbol class)
      (set wrapper-symbol (class-wrapper class))
      ;; This is a funky trick to rebuild the wrappers, next time they are
      ;; referenced. 
      (rplacd cell (list supers))
      (setf (symbol-function 'built-in-wrapper-of)
	    #'(lambda (x)
		(setf (symbol-function 'built-in-wrapper-of)
		      (compile nil
			       `(lambda (x)
				  ,(make-built-in-wrapper-of-body))))
		(built-in-wrapper-of x))
	    (symbol-function 'built-in-class-of)
	    #'(lambda (x)
		(setf (symbol-function 'built-in-class-of)
		      (compile nil
			       `(lambda (x)
				  ,(make-built-in-class-of-body))))
		(built-in-class-of x))))))

;;;
;;; Redefine the LISP defstruct macro so that structures are
;;; automatically added to the built-in-class lattice.  This is a very
;;; simple minded implementation that does not handle changing the
;;; inheritance of defstructs.
;;;
(eval-when (compile load eval)
  (unless (macro-function 'old-defstruct)
    (setf (macro-function 'old-defstruct) (macro-function 'defstruct))))
(defmacro DEFSTRUCT (name-and-options &rest body)
  (let* ((include (when (listp name-and-options)
		    (second (assoc :include (cdr name-and-options)))))
	 (supertype (or include #+lucid t))
	 (name (if (listp name-and-options)
		   (first name-and-options)
		   name-and-options)))
    `(eval-when (compile load eval)
       (define-built-in-class ',name '(,supertype))
       (old-defstruct ,name-and-options ,@body))))