Temporary work arounds for defgeneric and defstruct specializers

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

Here are two work arounds that I have been using for a while.  The
first defines a defgeneric that does the simple things like generate
setf methods and the generic function.  No guarantee is made that it
does everything.

The second work around allows you to write methods that specialize on
defstructs.  It is portable except for determining the super-type of a
structure.  Fill in your super-type at #+lucid.  There are some
problems with the workaround.  It causes the wrapper functions to get
recompiled the first time they are used after defining a structure.
It also potentially slows down dispatch since the extra tests for the
structures are included in the wrappers.  Anyway, if you really need
to write defstruct specializers, it works.  It might also be a good
idea to use a special macro rather than redefining defstruct, but at
least this way you don't have to think about it!

;;; -*- Mode: LISP; Package: pcl; Syntax: Common-lisp; Base: 10.;  -*- 

;;;%Header
;;;----------------------------------------------------------------------------
;;;
;;; CLOS extensions
;;;
;;; Author: Chris McConnell
;;;
(in-package 'pcl)
(export '(defgeneric))

;;;
;;; NOTE: Define defgeneric until it really exists...
(defmacro DEFGENERIC (name lambda-list &rest options)
  `(progn
     ,(when (listp name) 
	`(do-standard-defsetf-1 ',(second name)))
     (pcl::ensure-generic-function 
      ',name
      :lambda-list ',lambda-list
      ,@(let ((new nil))
	  (dolist (option options new)
	    (dolist (part (reverse option))
	      (push part new)))))))

;;;
;;; This whole set of hair is based on 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))))