(in-package "SB-PCL")
\f
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-;;; FIXME: These are non-ANSI hacks which it would be nice to get rid of.
-(defvar *defclass-times* '(:load-toplevel :execute)) ; You probably have
- ; to change this if you use
- ; DEFCONSTRUCTOR.
-(defvar *defmethod-times* '(:load-toplevel :execute))
-(defvar *defgeneric-times* '(:load-toplevel :execute))
-
-) ; EVAL-WHEN
-
-(eval-when (:load-toplevel :execute)
- (when (eq *boot-state* 'complete)
- (error "Trying to load (or compile) PCL in an environment in which it~%~
- has already been loaded. This doesn't work, you will have to~%~
- get a fresh lisp (reboot) and then load PCL."))
- (when *boot-state*
- (cerror "Try loading (or compiling) PCL anyways."
- "Trying to load (or compile) PCL in an environment in which it~%~
- has already been partially loaded. This may not work, you may~%~
- need to get a fresh lisp (reboot) and then load PCL."))
- ) ; EVAL-WHEN
+;;; (These are left over from the days when PCL was an add-on package
+;;; for a pre-CLOS Common Lisp. They shouldn't happen in a normal
+;;; build, of course, but they might happen if someone is experimenting
+;;; and debugging, and it's probably worth complaining if they do,
+;;; so we've left 'em in.)
+(when (eq *boot-state* 'complete)
+ (error "Trying to load (or compile) PCL in an environment in which it~%~
+ has already been loaded. This doesn't work, you will have to~%~
+ get a fresh lisp (reboot) and then load PCL."))
+(when *boot-state*
+ (cerror "Try loading (or compiling) PCL anyways."
+ "Trying to load (or compile) PCL in an environment in which it~%~
+ has already been partially loaded. This may not work, you may~%~
+ need to get a fresh lisp (reboot) and then load PCL."))
\f
-;;; This is like fdefinition on the Lispm. If Common Lisp had something like
-;;; function specs I wouldn't need this. On the other hand, I don't like the
-;;; way this really works so maybe function specs aren't really right either?
-;;;
-;;; I also don't understand the real implications of a Lisp-1 on this sort of
-;;; thing. Certainly some of the lossage in all of this is because these
-;;; SPECs name global definitions.
-;;;
-;;; Note that this implementation is set up so that an implementation which
-;;; has a 'real' function spec mechanism can use that instead and in that way
-;;; get rid of setf generic function names.
+;;; comments from CMU CL version of PCL:
+;;; This is like fdefinition on the Lispm. If Common Lisp had
+;;; something like function specs I wouldn't need this. On the other
+;;; hand, I don't like the way this really works so maybe function
+;;; specs aren't really right either?
+;;; I also don't understand the real implications of a Lisp-1 on this
+;;; sort of thing. Certainly some of the lossage in all of this is
+;;; because these SPECs name global definitions.
+;;; Note that this implementation is set up so that an implementation
+;;; which has a 'real' function spec mechanism can use that instead
+;;; and in that way get rid of setf generic function names.
(defmacro parse-gspec (spec
- (non-setf-var . non-setf-case)
- (setf-var . setf-case))
- (declare (indentation 1 1))
- #+setf (declare (ignore setf-var setf-case))
- (once-only (spec)
- `(cond (#-setf (symbolp ,spec) #+setf t
- (let ((,non-setf-var ,spec)) ,@non-setf-case))
- #-setf
- ((and (listp ,spec)
- (eq (car ,spec) 'setf)
- (symbolp (cadr ,spec)))
- (let ((,setf-var (cadr ,spec))) ,@setf-case))
- #-setf
- (t
- (error
- "Can't understand ~S as a generic function specifier.~%~
- It must be either a symbol which can name a function or~%~
- a list like ~S, where the car is the symbol ~S and the cadr~%~
- is a symbol which can name a generic function."
- ,spec '(setf <foo>) 'setf)))))
+ (non-setf-var . non-setf-case))
+ `(let ((,non-setf-var ,spec)) ,@non-setf-case))
;;; If symbol names a function which is traced or advised, return the
;;; unadvised, traced etc. definition. This lets me get at the generic
;;; function object even when it is traced.
(defun unencapsulated-fdefinition (symbol)
- (symbol-function symbol))
+ (fdefinition symbol))
;;; If symbol names a function which is traced or advised, redefine
;;; the `real' definition without affecting the advise.
(sb-c::%%defun name new-definition nil)
(sb-c::note-name-defined name :function)
new-definition)
- (setf (symbol-function name) new-definition))
+ (setf (fdefinition name) new-definition))
(defun gboundp (spec)
(parse-gspec spec
- (name (fboundp name))
- (name (fboundp (get-setf-function-name name)))))
+ (name (fboundp name))))
(defun gmakunbound (spec)
(parse-gspec spec
- (name (fmakunbound name))
- (name (fmakunbound (get-setf-function-name name)))))
+ (name (fmakunbound name))))
(defun gdefinition (spec)
(parse-gspec spec
- (name (or #-setf (macro-function name) ;??
- (unencapsulated-fdefinition name)))
- (name (unencapsulated-fdefinition (get-setf-function-name name)))))
+ (name (unencapsulated-fdefinition name))))
-(defun #-setf SETF\ SB-PCL\ GDEFINITION #+setf (setf gdefinition) (new-value
- spec)
+(defun (setf gdefinition) (new-value spec)
(parse-gspec spec
- (name (fdefine-carefully name new-value))
- (name (fdefine-carefully (get-setf-function-name name) new-value))))
+ (name (fdefine-carefully name new-value))))
\f
(declaim (special *the-class-t*
*the-class-vector* *the-class-symbol*
;;; interface
(defun type-from-specializer (specl)
- (cond ((eq specl 't)
- 't)
+ (cond ((eq specl t)
+ t)
((consp specl)
(unless (member (car specl) '(class prototype class-eq eql))
(error "~S is not a legal specializer type." specl))
(declare (special *the-class-t*))
(setq type (type-from-specializer type))
(if (atom type)
- (if (eq type 't)
+ (if (eq type t)
*the-class-t*
(error "bad argument to type-class"))
(case (car type)
(push (list class-name symbol) *built-in-wrapper-symbols*)
symbol)))
\f
-(pushnew 'class *variable-declarations*)
-(pushnew 'variable-rebinding *variable-declarations*)
+(pushnew '%class *variable-declarations*)
+(pushnew '%variable-rebinding *variable-declarations*)
(defun variable-class (var env)
(caddr (variable-declaration 'class var env)))
(defvar *name->class->slotd-table* (make-hash-table))
-;;; This is used by combined methods to communicate the next methods to
-;;; the methods they call. This variable is captured by a lexical variable
-;;; of the methods to give it the proper lexical scope.
+;;; This is used by combined methods to communicate the next methods
+;;; to the methods they call. This variable is captured by a lexical
+;;; variable of the methods to give it the proper lexical scope.
(defvar *next-methods* nil)
(defvar *not-an-eql-specializer* '(not-an-eql-specializer))
(defun plist-value (object name)
(getf (object-plist object) name))
-(defun #-setf SETF\ SB-PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value
- object
- name)
+(defun (setf plist-value) (new-value object name)
(if new-value
(setf (getf (object-plist object) name) new-value)
(progn
;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
;;; SB-PCL:*BUILT-IN-CLASSES*.
-(sb-int:/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
+(/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
(defvar *built-in-classes*
(labels ((direct-supers (class)
- (sb-int:/show "entering DIRECT-SUPERS" (sb-kernel::class-name class))
+ (/show "entering DIRECT-SUPERS" (sb-kernel::class-name class))
(if (typep class 'cl:built-in-class)
(sb-kernel:built-in-class-direct-superclasses class)
(let ((inherits (sb-kernel:layout-inherits
(sb-kernel:class-layout class))))
- (sb-int:/show inherits)
+ (/show inherits)
(list (svref inherits (1- (length inherits)))))))
(direct-subs (class)
- (sb-int:/show "entering DIRECT-SUBS" (sb-kernel::class-name class))
- (sb-int:collect ((res))
+ (/show "entering DIRECT-SUBS" (sb-kernel::class-name class))
+ (collect ((res))
(let ((subs (sb-kernel:class-subclasses class)))
- (sb-int:/show subs)
+ (/show subs)
(when subs
- (sb-int:dohash (sub v subs)
+ (dohash (sub v subs)
(declare (ignore v))
- (sb-int:/show sub)
+ (/show sub)
(when (member class (direct-supers sub))
(res sub)))))
(res)))
;; relevant cases.
42))))
(mapcar (lambda (kernel-bic-entry)
- (sb-int:/show "setting up" kernel-bic-entry)
+ (/show "setting up" kernel-bic-entry)
(let* ((name (car kernel-bic-entry))
(class (cl:find-class name)))
- (sb-int:/show name class)
+ (/show name class)
`(,name
,(mapcar #'cl:class-name (direct-supers class))
,(mapcar #'cl:class-name (direct-subs class))
sb-kernel:funcallable-instance
function stream)))
sb-kernel::*built-in-classes*))))
-(sb-int:/show "done setting up SB-PCL::*BUILT-IN-CLASSES*")
+(/show "done setting up SB-PCL::*BUILT-IN-CLASSES*")
\f
;;;; the classes that define the kernel of the metabraid
(:metaclass structure-class))
(defstruct (dead-beef-structure-object
- (:constructor |STRUCTURE-OBJECT class constructor|)))
+ (:constructor |STRUCTURE-OBJECT class constructor|)
+ (:copier nil)))
(defclass std-object (slot-object) ()
(:metaclass std-class))