Re: allowable specializers

[kanderso@DINO.BBN.COM]

Here is the software we use at BBN to make structures part of PCL.  It
works on LISPM, and KCL.  Unfortunately, CL does not specify enough
about defstruct to make this completely portable, so each
implementation must provide 3 functions.  Please forward any
improvements or suggestions back to me.  Someone else has mailed out
something like this, but i can't find his name at the moment.  He
modified defstruct to  automatically define a class, and recompiled
built-in-class-of every time.  I don't do either of these things,
because i don't think they are right.

The file contains all the soft you'll need to load this as a patch to
an existing PCL.

k
;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp;
Patch-File: Yes -*-

#||
;;; STRUCTURE-CLASS.

Integrates structures into the CLOS class hierarchy.  Before the first
method is defined on a structure, use DEFINE-STRUCTURE-CLASS to create
the corresponding class.  Classes will automatically be created any
included structures.

;;; Example following CLtL p 312.

(defstruct person name age sex)

(defstruct (person-in-space (:include person)) x y z)

(defstruct (astronaut (:include person-in-space) (:conc-name astro-))
  helmet-size
  (beverage 'tang))

(define-structure-class 'astronaut)

(pcl:defmethod olderp ((a astronaut) (b person))
  (> (astro-age a) (person-age b)))

(pcl:defmethod olderp ((b person) (a astronaut))
  (> (person-age b) (astro-age a)))

(setq a (make-astronaut :name 'mary :age 50 :sex 'female))
(setq b (make-person :name 'ken  :age 41 :sex 'male))

(olderp a b)
(olderp b a)
||#
(in-package "PCL")


;;; Patch PKG.LISP
(export '(define-structure-class structure) 'pcl)


;;; Patch LOW.LISP
;;; Each implementation must provide versions of the following functions:

(defmacro structurep (thing)
  `(typep ,thing 'structure))

(defun structure-name (thing)
  (declare (ignore thing))
  (error "An implementation specific version of STRUCTURE-NAME is
required."))

(defun defstruct-include (name)
  (declare (ignore name))
  ;; The name of the included structure type or NIL if none.
  (error "An implementation specific version of DEFSTRUCT-INCLUDE is
required."))

(defun describe-structure (thing)
  (print thing))


;;; Patch KCL-LOW.LISP
#+kcl
(setf (symbol-function 'structure-name)
      (symbol-function 'system::structure-name))

#+kcl
(defun defstruct-include (name)
  (get name 'system::structure-include))


;;; Patch 3600-LOW.LISP

;;; Each implementation must provide versions of these.
#+3600
(defmacro structurep (thing)
  `(scl:named-structure-p ,thing))

#+3600
(defmacro structure-name (thing)
  "Given a struct, return its type name."
  `(scl:named-structure-p ,thing))

#+3600
(defun find-defstruct-description (name &optional (errorp t))
  (let ((description (get name 'si:defstruct-description)))
    (if description description
	(if errorp
	   (error "A structure with this name has not been defined" name)))))

#+3600
(defun defstruct-include (name)
  (car (si:defstruct-description-include (find-defstruct-description
name))))
#+3600
(defun describe-structure (thing)
  (LET ((NSS (si:NAMED-STRUCTURE-P THING)))
       (COND ((AND NSS (GET NSS 'si:NAMED-STRUCTURE-INVOKE)
		   (MEMQ ':DESCRIBE (si:NAMED-STRUCTURE-INVOKE THING
':WHICH-OPERATIONS)))
	      (si:NAMED-STRUCTURE-INVOKE THING ':DESCRIBE)
	      (si:DESCRIBE-ARRAY THING T))
	     ((AND NSS (GET NSS 'si:DEFSTRUCT-DESCRIPTION))
	      (si:DESCRIBE-DEFSTRUCT THING)
	      (si:DESCRIBE-ARRAY THING T))
	     (T
	      (si:DESCRIBE-ARRAY THING)))))


;;; Patch LOW.LISP

(EVAL-WHEN (compile load)
 (setq *class-of*
	'(lambda (x)
	   (or (and (iwmc-class-p x)
		    (wrapper-class (iwmc-class-class-wrapper x)))
	       (and (funcallable-instance-p x)
		    (funcallable-instance-class x))
	       (and (structurep x)
		    (structure-class-of x))
	       (built-in-class-of x)
	       (error "Can't determine class of ~S" x))))

 (setq *wrapper-of*
	'(lambda (x)
	   (or (and (iwmc-class-p x)
		    (iwmc-class-class-wrapper x))
	       (and (funcallable-instance-p x)
		    (funcallable-instance-wrapper x))
	       (and (structurep x)
		    (class-wrapper (structure-class-of x)))
	       (built-in-wrapper-of x)
	       (error "Can't determine wrapper of ~S" x))))
 ) ; End EVAL-WHEN						


;;; Patch BRAID1.LISP

(defun class-of (x) (#.*class-of* x))

(defun wrapper-of (x) (#.*wrapper-of* x))


;;; Patch HIGH.LISP

(eval-when (compile load eval)
  
;;; Added structure as a built in class
(setq *built-in-classes*
	'((array             (t))
	  (bit-vector        (vector))
	  (character         (t))
	  (complex           (number))
	  (cons              (list))
	  (float             (number))
	  (integer           (rational))
	  (list              (sequence))
	  (null              (symbol list))
	  (number            (t))
	  (ratio             (rational))
	  (rational          (number))
	  (sequence          (t))
	  (string            (vector))
	  (symbol            (t))
	  (vector            (array sequence))
	  (hash-table        (t))
	  (structure         (t))))

(define-built-in-classes)

)

;;; This needs to be eval-when'ed when HIGH.LISP is compiled, so it
;;; needs to be here too to work as a patch.
(eval-when (compile eval)
(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)))))
)					; End Eval-when

(defun built-in-wrapper-of (x)
  #.(make-built-in-wrapper-of-body))

(defun built-in-class-of (x)
  #.(make-built-in-class-of-body))

(defclass structure-class (standard-class)
     ((class-precedence-list
	:initform (list *the-class-t*))))

(defmethod inform-type-system-about-class ((class structure-class) name)
  ;; Defstruct informs the type system for us.
  (declare (ignore name)))

;; This assumes that MAKE-FOO will always work.
(defmethod class-prototype ((c structure-class))
  (or (slot-value c 'prototype)
      (setf (slot-value c 'prototype)
	    ;; Gross! Is there a better way?
	    (funcall (intern (format nil "MAKE-~A" (class-name c))
			     (symbol-package (class-name c)))))))

(defmethod allocate-instance ((class structure-class) &rest initargs)
  (declare (ignore initargs))
  (error "Attempt to make an instance of the structure-class ~S.~@
          It is not possible to make instance of structure classes with~@
          allocate-instance."
	 class))

(defmethod check-super-metaclass-compatibility ((class structure-class)
						(new-super built-in-class))
  (or (eq new-super (find-class 'structure))
      (error "~S cannot have ~S as a super.~%~
              The only meta-class STANDARD-CLASS class that a structure~%~
              class can have as a super is the class STRUCTURE."
	     class new-super)))

(defmethod check-super-metaclass-compatibility ((class structure-class)
						(new-super structure-class))
  't)

(defun define-structure-class (name)
  (let ((proto (class-prototype (find-class 'structure-class)))
	(supers					
	  (list (let ((include (defstruct-include name)))
		  (if include (find-structure-class include)
		      (find-class 'structure))))))
    (add-named-class proto name supers () ())))

(defun find-structure-class (name)
  "Find structure-class named NAME, creating it if necessary."
  (let ((class (find-class name nil)))
    (if class class
	(define-structure-class name))))

(defun structure-class-of (structure)
  (find-structure-class (structure-name structure)))

(defmethod describe
	   #-Symbolics ((object structure))
	   #+Symbolics ((object structure) &optional no-complaints)
  #+Symbolics
  (declare (ignore no-complaints))
  (describe-structure object))