(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
;;; comments from CMU CL version of PCL:
;;; This is like fdefinition on the Lispm. If Common Lisp had
;;; 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))
- #+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*
\f
;;;; type specifier hackery
-;;; internal to this file.
+;;; internal to this file
(defun coerce-to-class (class &optional make-forward-referenced-class-p)
(if (symbolp class)
(or (find-class class (not make-forward-referenced-class-p))
(ensure-class class))
class))
-;;; Interface
+;;; interface
(defun specializer-from-type (type &aux args)
(when (consp type)
(setq args (cdr type) type (car type)))
;;; 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)
(defun inform-type-system-about-std-class (name)
(let ((predicate-name (make-type-predicate-name name)))
(setf (gdefinition predicate-name)
- (make-type-predicate name))
- (do-satisfies-deftype name predicate-name)))
+ (make-type-predicate name))))
(defun make-type-predicate (name)
(let ((cell (find-class-cell name)))
#'(lambda (x)
(funcall (the function (find-class-cell-predicate cell)) x))))
-;This stuff isn't right. Good thing it isn't used.
-;The satisfies predicate has to be a symbol. There is no way to
-;construct such a symbol from a class object if class names change.
-(defun class-predicate (class)
- (when (symbolp class) (setq class (find-class class)))
- #'(lambda (object) (memq class (class-precedence-list (class-of object)))))
-
-(defun make-class-eq-predicate (class)
- (when (symbolp class) (setq class (find-class class)))
- #'(lambda (object) (eq class (class-of object))))
-
-(defun make-eql-predicate (eql-object)
- #'(lambda (object) (eql eql-object object)))
-
-#|| ; The argument to satisfies must be a symbol.
-(deftype class (&optional class)
- (if class
- `(satisfies ,(class-predicate class))
- `(satisfies ,(class-predicate 'class))))
-
-(deftype class-eq (class)
- `(satisfies ,(make-class-eq-predicate class)))
-||#
+(defun make-type-predicate-name (name &optional kind)
+ (if (symbol-package name)
+ (intern (format nil
+ "~@[~A ~]TYPE-PREDICATE ~A ~A"
+ kind
+ (package-name (symbol-package name))
+ (symbol-name name))
+ *pcl-package*)
+ (make-symbol (format nil
+ "~@[~A ~]TYPE-PREDICATE ~A"
+ kind
+ (symbol-name name)))))
-;;; internal to this file
+;;; internal to this file..
;;;
-;;; These functions are a pale imitiation of their namesake. They accept
+;;; These functions are a pale imitation of their namesake. They accept
;;; class objects or types where they should.
(defun *normalize-type (type)
(cond ((consp type)
(t
(error "~S is not a type." type))))
-;;; Not used...
-#+nil
-(defun unparse-type-list (tlist)
- (mapcar #'unparse-type tlist))
-
-;;; Not used...
-#+nil
-(defun unparse-type (type)
- (if (atom type)
- (if (specializerp type)
- (unparse-type (specializer-type type))
- type)
- (case (car type)
- (eql type)
- (class-eq `(class-eq ,(class-name (cadr type))))
- (class (class-name (cadr type)))
- (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
-
;;; internal to this file...
(defun convert-to-system-type (type)
(case (car type)
(car type)
type))))
-;;; not used...
-#+nil
-(defun *typep (object type)
- (setq type (*normalize-type type))
- (cond ((member (car type) '(eql wrapper-eq class-eq class))
- (specializer-applicable-using-type-p type `(eql ,object)))
- ((eq (car type) 'not)
- (not (*typep object (cadr type))))
- (t
- (typep object (convert-to-system-type type)))))
-
-;;; Writing the missing NOT and AND clauses will improve
-;;; the quality of code generated by generate-discrimination-net, but
-;;; calling subtypep in place of just returning (values nil nil) can be
-;;; very slow. *SUBTYPEP is used by PCL itself, and must be fast.
+;;; Writing the missing NOT and AND clauses will improve the quality
+;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
+;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
+;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
+;;;
+;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
+;;; in the compiler. Could we share some of it here?
(defun *subtypep (type1 type2)
(if (equal type1 type2)
(values t t)
(values (eq type1 type2) t)
(let ((*in-precompute-effective-methods-p* t))
(declare (special *in-precompute-effective-methods-p*))
- ;; *in-precompute-effective-methods-p* is not a good name.
- ;; It changes the way class-applicable-using-class-p works.
+ ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a
+ ;; good name. It changes the way
+ ;; CLASS-APPLICABLE-USING-CLASS-P works.
(setq type1 (*normalize-type type1))
(setq type2 (*normalize-type type2))
(case (car type2)
(not
- (values nil nil)) ; Should improve this.
+ (values nil nil)) ; XXX We should improve this.
(and
- (values nil nil)) ; Should improve this.
+ (values nil nil)) ; XXX We should improve this.
((eql wrapper-eq class-eq class)
(multiple-value-bind (app-p maybe-app-p)
(specializer-applicable-using-type-p type2 type1)
(t
(subtypep (convert-to-system-type type1)
(convert-to-system-type type2))))))))
-
-(defun do-satisfies-deftype (name predicate)
- (declare (ignore name predicate)))
-
-(defun make-type-predicate-name (name &optional kind)
- (if (symbol-package name)
- (intern (format nil
- "~@[~A ~]TYPE-PREDICATE ~A ~A"
- kind
- (package-name (symbol-package name))
- (symbol-name name))
- *pcl-package*)
- (make-symbol (format nil
- "~@[~A ~]TYPE-PREDICATE ~A"
- kind
- (symbol-name name)))))
\f
(defvar *built-in-class-symbols* ())
(defvar *built-in-wrapper-symbols* ())
(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
(defclass sb-kernel:funcallable-instance (function) ()
(:metaclass built-in-class))
-(defclass stream (t) ()
+(defclass stream (sb-kernel:instance) ()
(:metaclass built-in-class))
(defclass slot-object (t) ()
(: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))
projects / sbcl.git / blobdiff