;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation. All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox Artifical Intelligence Systems
;;; 2400 Hanover St.
;;; Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; Non-Bootstrap stuff
;;;
(in-package 'pcl)
(defclass forward-referenced-class (class) ())
(defmethod check-super-metaclass-compatibility ((c class)
(f forward-referenced-class))
(declare (ignore c f))
't)
(defmethod class-for-redefinition ((existing-class forward-referenced-class)
(proto-class class)
name
supers
slots
options)
(declare (ignore name supers slots options))
(change-class existing-class (class-of proto-class))
existing-class)
(defclass obsolete-class (class) ())
(defmethod slot-value-using-class ((class obsolete-class)
object
slot-name
&optional dont-call-slot-missing-p
default)
(change-class object
(cadr (slot-value class 'class-precedence-list)))
(slot-value-using-class
(class-of object) object slot-name dont-call-slot-missing-p default))
;;;
;;;
;;;
(defclass built-in-class (class) ())
(defmethod inform-type-system-about-class ((class built-in-class) name)
(declare (ignore class name)))
(defmethod allocate-instance ((class built-in-class))
(error
"Attempt to make an instance of the built-in class ~S.~%~
It is not possible to make instance of built-in classes with ~
allocate-instance."
class))
(defmethod check-super-metaclass-compatibility ((bic built-in-class)
(new-super class))
(or (eq new-super (class-named 't))
(error "~S cannot have ~S as a super.~%~
The only meta-class CLASS class that a built-in class can~%~
have as a super is the class T."
bic new-super)))
(defmethod check-super-metaclass-compatibility ((class built-in-class)
(new-super built-in-class))
(declare (ignore class new-super))
't)
(defmethod check-super-metaclass-compatibility
((built-in built-in-class)
(new-super forward-referenced-class))
(declare (ignore built-in new-super))
't)
;;;
;;;
;;;
(defvar *built-in-class-lattice* ())
(defmacro define-built-in-classes (classes-and-supers &optional reset-p)
`(eval-when (eval load)
(when ,reset-p (setq *built-in-class-lattice* ()))
(dolist (bic ,classes-and-supers)
(pushnew bic *built-in-class-lattice* :test #'equal))
(define-built-in-classes-1)
(setf (symbol-function 'built-in-class-of)
#'(lambda (x)
(declare (notinline built-in-class-of))
(compile 'built-in-class-of (make-built-in-class-of))
(built-in-class-of x)))))
(defun define-built-in-classes-1 ()
;; First make sure that all the supers listed in *built-in-class-lattice*
;; are themselves defined by *built-in-class-lattice*. This is just to
;; check for typos and other sorts of brainos.
;;
;; At the same time make sure the subtype relationship specified here in
;; *built-in-class-lattice* agrees with the subtype relationship in this
;; Lisp.
(dolist (e *built-in-class-lattice*)
(dolist (super (cadr e))
; (unless (and (eq (subtypep (car e) super) 't) ;*** Lame, should
; (eq (subtypep super (car e)) 'nil)) ;*** check supers.
; (warn "*built-in-class-lattice* and this Lisp may disagree about~%~
; the type relationship between ~S and ~S."
; (car e) super))
(unless (or (eq super 't)
(assq super *built-in-class-lattice*))
(error "In *built-in-class-lattice*: ~S has ~S as a super,~%~
but ~S is not itself a class in *built-in-class-lattice*."
(car e) super super))))
;; Now use add-named-class to define the built-in class as specified.
;;
(let ((proto (class-prototype (class-named 'built-in-class))))
(dolist (e *built-in-class-lattice*)
(add-named-class proto (car e) (cadr e) () ())))
)
(defun make-built-in-class-tree ()
(let ((tree (list 't)))
(labels ((insert-subs (node type)
(dolist (e *built-in-class-lattice*)
(let ((e-type (car e))
(e-supers (cadr e)))
(when (and (memq type e-supers)
(not (member e-type (cdr node) :key #'car)))
(let ((new-node (list e-type)))
(push new-node (cdr node))
(insert-subs new-node e-type)))))))
(insert-subs tree 't)
tree)))
(defun make-built-in-class-of ()
`(lambda (x) ,(make-built-in-class-of-1 (make-built-in-class-tree) 'x)))
(defun make-built-in-class-of-1 (tree var)
`(and (typep ,var ',(car tree))
(or ,@(mapcar #'(lambda (x) (make-built-in-class-of-1 x var))
(cdr tree))
,(class-constant-form (class-named (car tree)))
)))
(define-built-in-classes '((array (t))
(bit-vector (vector))
(character (t))
; (compiled-function (t))
(complex (number))
(cons (list))
(float (number))
(integer (rational))
(list (sequence))
; (nil ()) ;*** fix this
(null (list symbol))
(number (t))
(ratio (rational))
(rational (number))
(sequence (t))
(string (vector))
(symbol (t))
(vector (array sequence))))
;;;
;;;
;;;
(defmethod describe-class (class-or-class-name
&optional (stream *standard-output*))
(flet ((pretty-class (class) (or (class-name class) class)))
(if (symbolp class-or-class-name)
(describe-class (class-named class-or-class-name) stream)
(let ((class class-or-class-name))
(format stream
"~&The class ~S is an instance of class ~S."
class
(class-of class))
(format stream "~&Name:~23T~S~%~
Class-Precedence-List:~23T~S~%~
Local-Supers:~23T~S~%~
Direct-Subclasses:~23T~S"
(class-name class)
(mapcar #'pretty-class (class-class-precedence-list class))
(mapcar #'pretty-class (class-local-supers class))
(mapcar #'pretty-class (class-direct-subclasses class)))
class))))
(defun describe-instance (object &optional (stream t))
(let* ((class (class-of object))
(instance-slots (class-instance-slots class))
(non-instance-slots (class-non-instance-slots class))
(dynamic-slots (iwmc-class-dynamic-slots object))
(max-slot-name-length 0))
(macrolet ((adjust-slot-name-length (name)
`(setq max-slot-name-length
(max max-slot-name-length
(length (the string (symbol-name ,name))))))
(describe-slot (name value &optional (allocation () alloc-p))
(if alloc-p
`(format stream
"~% ~A ~S ~VT ~S"
,name ,allocation (+ max-slot-name-length 7)
,value)
`(format stream
"~% ~A~VT ~S"
,name max-slot-name-length ,value))))
;; Figure out a good width for the slot-name column.
(iterate ((slotd in instance-slots))
(adjust-slot-name-length (slotd-name slotd)))
(iterate ((slotd in non-instance-slots))
(adjust-slot-name-length (slotd-name slotd)))
(iterate ((name in dynamic-slots by cddr))
(adjust-slot-name-length name))
(setq max-slot-name-length (min (+ max-slot-name-length 3) 30))
(format stream "~%~S is an instance of class ~S:" object class)
(format stream "~% The following slots are allocated in the instance ~
(:INSTANCE allocation):")
(iterate ((slotd in instance-slots))
(let ((name (slotd-name slotd)))
(describe-slot name (slot-value object name))))
(when (or dynamic-slots
(iterate ((slotd in non-instance-slots))
(when (neq (slotd-allocation slotd) :dynamic) (return t))))
(format stream
"~%The following slots have special allocations as shown:")
(iterate ((slotd in non-instance-slots))
(unless (eq (slotd-allocation slotd) :dynamic)
(describe-slot (slotd-name slotd)
(slot-value object (slotd-name slotd))
(slotd-allocation slotd))))
(iterate ((name in dynamic-slots by cddr)
(val in (cdr dynamic-slots) by cddr))
(describe-slot name val :dynamic)))))
object)
;;;
;;; trace-method and untrace-method accept method specs as arguments. A
;;; method-spec should be a list like:
;;; (<generic-function-spec> qualifiers* (specializers*))
;;; where <generic-function-spec> should be either a symbol or a list
;;; of (SETF <symbol>).
;;;
;;; For example, to trace the method defined by:
;;;
;;; (defmethod foo ((x spaceship)) 'ss)
;;;
;;; You should say:
;;;
;;; (trace-method '(foo (spaceship)))
;;;
;;; You can also provide a method object in the place of the method
;;; spec, in which case that method object will be traced.
;;;
;;; For untrace-method, if an argument is given, that method is untraced.
;;; If no argument is given, all traced methods are untraced.
;;;
(defvar *traced-methods* ())
(defun trace-method (spec)
(multiple-value-bind (gf method name)
(parse-method-or-spec spec)
(put-slot-always method 'untrace (list name (method-function method)))
(push method *traced-methods*)
(trace-method-internal gf method name)
method))
(defun untrace-method (&optional spec)
(flet ((untrace-it (m)
(let ((untrace (and (slot-exists-p m 'untrace)
(slot-value m 'untrace))))
(if untrace
(progn
(eval `(untrace ,(car untrace)))
(setf (method-function m) (cadr untrace))
(remove-dynamic-slot m 'untrace))
(error "~S is not a traced method?" m)))))
(cond ((not (null spec))
(multiple-value-bind (gf method)
(parse-method-or-spec spec)
(when (method-generic-function method)
(untrace-it method)
(setq *traced-methods* (delete method *traced-methods*))
(list *traced-methods*))))
(t
(dolist (m *traced-methods*)
(untrace-it m))
(prog1 *traced-methods*
(setq *traced-methods* ()))))))
(defun trace-method-internal (gf method name)
(let ((function (method-function method)))
(eval `(untrace ,name))
(setf (symbol-function name) function)
(eval `(trace ,name))
(setf (method-function method) (symbol-function name))))
(defun compile-method (spec)
(multiple-value-bind (gf method name)
(parse-method-or-spec spec)
(declare (ignore gf))
(compile name (method-function method))
(setf (method-function method) (symbol-function name))))
(defmacro undefmethod (&rest args)
(declare (arglist name {method-qualifier}* specializers))
(multiple-value-bind (gf method)
(parse-method-or-spec args)
(remove-method gf method)
method))
(defmacro undefmethod-setf (&rest args)
(declare (arglist name {method-qualifier}* specializers setf-specializers))
(multiple-value-bind (name qualifiers specls setf-specls)
(parse-defmethod args t)
(multiple-value-bind (gf method)
(parse-method-or-spec `((setf ,name)
,@qualifiers
(,@specls ,@setf-specls)))
(remove-method gf method)
method)))