(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.
+;;; If symbol names a function which is traced, return the untraced
+;;; definition. This lets us get at the generic function object even
+;;; when it is traced.
(defun unencapsulated-fdefinition (symbol)
(fdefinition symbol))
-;;; If symbol names a function which is traced or advised, redefine
-;;; the `real' definition without affecting the advise.
+;;; If symbol names a function which is traced, redefine the `real'
+;;; definition without affecting the trace.
(defun fdefine-carefully (name new-definition)
(progn
- (sb-c::%%defun name new-definition nil)
(sb-c::note-name-defined name :function)
new-definition)
(setf (fdefinition name) new-definition))
(if (atom type)
(if (eq type t)
*the-class-t*
- (error "bad argument to type-class"))
+ (error "bad argument to TYPE-CLASS"))
(case (car type)
(eql (class-of (cadr type)))
(prototype (class-of (cadr 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))))
+ (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* ())
(push (list class-name symbol) *built-in-wrapper-symbols*)
symbol)))
\f
-(pushnew '%class *variable-declarations*)
-(pushnew '%variable-rebinding *variable-declarations*)
+(pushnew '%class *var-declarations*)
+(pushnew '%variable-rebinding *var-declarations*)
(defun variable-class (var env)
- (caddr (variable-declaration 'class var env)))
+ (caddr (var-declaration 'class var env)))
(defvar *name->class->slotd-table* (make-hash-table))
(defmacro define-gf-predicate (predicate-name &rest classes)
`(progn
(defmethod ,predicate-name ((x t)) nil)
- ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
+ ,@(mapcar (lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
classes)))
(defun make-class-predicate-name (name)
(/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
(defvar *built-in-classes*
(labels ((direct-supers (class)
- (/show "entering DIRECT-SUPERS" (sb-kernel::class-name class))
+ (/noshow "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))))
- (/show inherits)
+ (/noshow inherits)
(list (svref inherits (1- (length inherits)))))))
(direct-subs (class)
- (/show "entering DIRECT-SUBS" (sb-kernel::class-name class))
+ (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class))
(collect ((res))
(let ((subs (sb-kernel:class-subclasses class)))
- (/show subs)
+ (/noshow subs)
(when subs
(dohash (sub v subs)
(declare (ignore v))
- (/show sub)
+ (/noshow sub)
(when (member class (direct-supers sub))
(res sub)))))
(res)))
;; relevant cases.
42))))
(mapcar (lambda (kernel-bic-entry)
- (/show "setting up" kernel-bic-entry)
+ (/noshow "setting up" kernel-bic-entry)
(let* ((name (car kernel-bic-entry))
(class (cl:find-class name)))
- (/show name class)
+ (/noshow 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*))))
-(/show "done setting up SB-PCL::*BUILT-IN-CLASSES*")
+(/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
\f
;;;; the classes that define the kernel of the metabraid
())
(defclass effective-slot-definition (slot-definition)
- ((reader-function ; #'(lambda (object) ...)
+ ((reader-function ; (lambda (object) ...)
:accessor slot-definition-reader-function)
- (writer-function ; #'(lambda (new-value object) ...)
+ (writer-function ; (lambda (new-value object) ...)
:accessor slot-definition-writer-function)
- (boundp-function ; #'(lambda (object) ...)
+ (boundp-function ; (lambda (object) ...)
:accessor slot-definition-boundp-function)
(accessor-flags
:initform 0)))
projects / sbcl.git / blobdiff