X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=f65650e7e8c3ac16f7ec5bce55323cd40787307d;hb=1513b29bfbe948e7b431b5f67f1ff10769c192cf;hp=5943a8db63033eda17475a789701e6ffb663b987;hpb=0b5610d8a220a4b20cbeac958953ca4d67c00038;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 5943a8d..f65650e 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -130,14 +130,14 @@ ;;;; 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))) @@ -178,7 +178,7 @@ (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))) ;? @@ -191,41 +191,29 @@ (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) @@ -246,24 +234,6 @@ (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) @@ -276,21 +246,13 @@ (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) @@ -298,15 +260,16 @@ (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) @@ -314,22 +277,6 @@ (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))))) (defvar *built-in-class-symbols* ()) (defvar *built-in-wrapper-symbols* ()) @@ -541,7 +488,7 @@ (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) ()