X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=2d9bcf0e9e40a33ea053ce63f948dcbea31d068b;hb=416152f084604094445a758ff399871132dff2bd;hp=dcaa9eb4e796285ee292ffc50fb1082dc1e621e5;hpb=475c832b081651e66ad9446d4852c62086f5e740;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index dcaa9eb..2d9bcf0 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -23,18 +23,20 @@ (in-package "SB-PCL") - -(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.")) ;;; comments from CMU CL version of PCL: ;;; This is like fdefinition on the Lispm. If Common Lisp had @@ -51,20 +53,19 @@ (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) - (name-get-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) - (name-set-fdefinition name new-definition)) + (setf (fdefinition name) new-definition)) (defun gboundp (spec) (parse-gspec spec @@ -128,14 +129,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))) @@ -154,8 +155,8 @@ ;;; 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)) @@ -174,9 +175,9 @@ (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")) + (error "bad argument to TYPE-CLASS")) (case (car type) (eql (class-of (cadr type))) (prototype (class-of (cadr type))) ;? @@ -189,41 +190,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) @@ -244,24 +233,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) @@ -274,21 +245,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) @@ -296,15 +259,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) @@ -312,22 +276,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* ()) @@ -454,25 +402,25 @@ ;;; 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)) + (/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)))) - (sb-int:/show inherits) + (/noshow 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)) + (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class)) + (collect ((res)) (let ((subs (sb-kernel:class-subclasses class))) - (sb-int:/show subs) + (/noshow subs) (when subs - (sb-int:dohash (sub v subs) + (dohash (sub v subs) (declare (ignore v)) - (sb-int:/show sub) + (/noshow sub) (when (member class (direct-supers sub)) (res sub))))) (res))) @@ -500,10 +448,10 @@ ;; relevant cases. 42)))) (mapcar (lambda (kernel-bic-entry) - (sb-int:/show "setting up" kernel-bic-entry) + (/noshow "setting up" kernel-bic-entry) (let* ((name (car kernel-bic-entry)) (class (cl:find-class name))) - (sb-int:/show name class) + (/noshow name class) `(,name ,(mapcar #'cl:class-name (direct-supers class)) ,(mapcar #'cl:class-name (direct-subs class)) @@ -523,7 +471,7 @@ sb-kernel:funcallable-instance function stream))) sb-kernel::*built-in-classes*)))) -(sb-int:/show "done setting up SB-PCL::*BUILT-IN-CLASSES*") +(/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*") ;;;; the classes that define the kernel of the metabraid @@ -539,7 +487,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) () @@ -549,7 +497,8 @@ (: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))