/[cmucl]/src/code/pred.lisp
ViewVC logotype

Diff of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.62 by rtoy, Mon Nov 2 15:05:06 2009 UTC revision 1.62.2.2 by rtoy, Wed Feb 10 01:53:31 2010 UTC
# Line 15  Line 15 
15  ;;;  ;;;
16    
17  (in-package "KERNEL")  (in-package "KERNEL")
18    (intl:textdomain "cmucl")
19    
20  (export '(%instancep instance fixnump bignump bitp ratiop weak-pointer-p  (export '(%instancep instance fixnump bignump bitp ratiop weak-pointer-p
21            %typep class-cell-typep))            %typep class-cell-typep))
22    
# Line 136  Line 138 
138  ;;; it is not permitted to return member types.  ;;; it is not permitted to return member types.
139  ;;;  ;;;
140  (defun type-of (object)  (defun type-of (object)
141    "Return the type of OBJECT."    _N"Return the type of OBJECT."
142    (typecase object    (typecase object
143      ((or array complex)      ((or array complex)
144       (type-specifier (ctype-of object)))       (type-specifier (ctype-of object)))
# Line 165  Line 167 
167  ;;;; UPGRADED-ARRAY-ELEMENT-TYPE  --  public  ;;;; UPGRADED-ARRAY-ELEMENT-TYPE  --  public
168  ;;;  ;;;
169  (defun upgraded-array-element-type (spec &optional environment)  (defun upgraded-array-element-type (spec &optional environment)
170    "Return the element type that will actually be used to implement an array    _N"Return the element type that will actually be used to implement an array
171     with the specifier :ELEMENT-TYPE Spec."     with the specifier :ELEMENT-TYPE Spec."
172    ;; Type expansion (TYPE-EXPAND) currently doesn't handle environments.    ;; Type expansion (TYPE-EXPAND) currently doesn't handle environments.
173    (declare (ignore environment))    (declare (ignore environment))
# Line 178  Line 180 
180  ;;; Just parse the type specifiers and call csubtype.  ;;; Just parse the type specifiers and call csubtype.
181  ;;;  ;;;
182  (defun subtypep (type1 type2 &optional environment)  (defun subtypep (type1 type2 &optional environment)
183    "Return two values indicating the relationship between type1 and type2:    _N"Return two values indicating the relationship between type1 and type2:
184    T and T: type1 definitely is a subtype of type2.    T and T: type1 definitely is a subtype of type2.
185    NIL and T: type1 definitely is not a subtype of type2.    NIL and T: type1 definitely is not a subtype of type2.
186    NIL and NIL: who knows?"    NIL and NIL: who knows?"
# Line 195  Line 197 
197  ;;; Just call %typep  ;;; Just call %typep
198  ;;;  ;;;
199  (defun typep (object type &optional environment)  (defun typep (object type &optional environment)
200    "Return T iff OBJECT is of type TYPE."    _N"Return T iff OBJECT is of type TYPE."
201    (declare (ignore environment))    (declare (ignore environment))
202    (%typep object type))    (%typep object type))
203    
# Line 268  Line 270 
270            (if (unknown-type-p (array-type-element-type type))            (if (unknown-type-p (array-type-element-type type))
271                ;; better to fail this way than to get bogosities like                ;; better to fail this way than to get bogosities like
272                ;;   (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T                ;;   (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
273                (error "~@<unknown element type in array type: ~2I~_~S~:>"                (error _"~@<unknown element type in array type: ~2I~_~S~:>"
274                       (type-specifier type))                       (type-specifier type))
275                t)                t)
276            (or (eq (array-type-element-type type) *wild-type*)            (or (eq (array-type-element-type type) *wild-type*)
# Line 293  Line 295 
295       ;; Parse it again to make sure it's really undefined.       ;; Parse it again to make sure it's really undefined.
296       (let ((reparse (specifier-type (unknown-type-specifier type))))       (let ((reparse (specifier-type (unknown-type-specifier type))))
297         (if (typep reparse 'unknown-type)         (if (typep reparse 'unknown-type)
298             (error "Unknown type specifier: ~S"             (error _"Unknown type specifier: ~S"
299                    (unknown-type-specifier reparse))                    (unknown-type-specifier reparse))
300             (%%typep object reparse))))             (%%typep object reparse))))
301      (negation-type      (negation-type
# Line 312  Line 314 
314           ;; HAIRY-TYPE for them.           ;; HAIRY-TYPE for them.
315           (not           (not
316            (unless (and (listp hairy-spec) (= (length hairy-spec) 2))            (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
317              (error "Invalid type specifier: ~S" hairy-spec))              (error _"Invalid type specifier: ~S" hairy-spec))
318            (not (%%typep object (specifier-type (cadr hairy-spec)))))            (not (%%typep object (specifier-type (cadr hairy-spec)))))
319           (satisfies           (satisfies
320            (unless (and (listp hairy-spec) (= (length hairy-spec) 2))            (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
321              (error "Invalid type specifier: ~S" hairy-spec))              (error _"Invalid type specifier: ~S" hairy-spec))
322            (let ((fn (cadr hairy-spec)))            (let ((fn (cadr hairy-spec)))
323              (if (funcall (typecase fn              (if (funcall (typecase fn
324                             (function fn)                             (function fn)
# Line 329  Line 331 
331      (alien-type-type      (alien-type-type
332       (alien-internals:alien-typep object (alien-type-type-alien-type type)))       (alien-internals:alien-typep object (alien-type-type-alien-type type)))
333      (function-type      (function-type
334       (error "Function types are not a legal argument to TYPEP:~%  ~S"       (error _"Function types are not a legal argument to TYPEP:~%  ~S"
335              (type-specifier type)))))              (type-specifier type)))))
336    
337    
# Line 341  Line 343 
343  (defun class-cell-typep (obj-layout cell object)  (defun class-cell-typep (obj-layout cell object)
344    (let ((class (class-cell-class cell)))    (let ((class (class-cell-class cell)))
345      (unless class      (unless class
346        (error "Class has not yet been defined: ~S" (class-cell-name cell)))        (error _"Class has not yet been defined: ~S" (class-cell-name cell)))
347      (class-typep obj-layout class object)))      (class-typep obj-layout class object)))
348    
349    
# Line 354  Line 356 
356    (when (layout-invalid obj-layout)    (when (layout-invalid obj-layout)
357      (if (and (typep (kernel::class-of object) 'kernel::standard-class) object)      (if (and (typep (kernel::class-of object) 'kernel::standard-class) object)
358          (setq obj-layout (pcl::check-wrapper-validity object))          (setq obj-layout (pcl::check-wrapper-validity object))
359          (error "TYPEP on obsolete object (was class ~S)."          (error _"TYPEP on obsolete object (was class ~S)."
360                 (class-proper-name (layout-class obj-layout)))))                 (class-proper-name (layout-class obj-layout)))))
361    (let ((layout (%class-layout class))    (let ((layout (%class-layout class))
362          (obj-inherits (layout-inherits obj-layout)))          (obj-inherits (layout-inherits obj-layout)))
363      (when (layout-invalid layout)      (when (layout-invalid layout)
364        (error "Class is currently invalid: ~S" class))        (error _"Class is currently invalid: ~S" class))
365      (or (eq obj-layout layout)      (or (eq obj-layout layout)
366          (dotimes (i (length obj-inherits) nil)          (dotimes (i (length obj-inherits) nil)
367            (when (eq (svref obj-inherits i) layout)            (when (eq (svref obj-inherits i) layout)
# Line 376  Line 378 
378  ;;;  ;;;
379    
380  (defun eq (obj1 obj2)  (defun eq (obj1 obj2)
381    "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."    _N"Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
382    (eq obj1 obj2))    (eq obj1 obj2))
383    
384    
385  ;;; EQUAL -- public.  ;;; EQUAL -- public.
386  ;;;  ;;;
387  (defun equal (x y)  (defun equal (x y)
388    "Returns T if X and Y are EQL or if they are structured components    _N"Returns T if X and Y are EQL or if they are structured components
389    whose elements are EQUAL.  Strings and bit-vectors are EQUAL if they    whose elements are EQUAL.  Strings and bit-vectors are EQUAL if they
390    are the same length and have indentical components.  Other arrays must be    are the same length and have indentical components.  Other arrays must be
391    EQ to be EQUAL."    EQ to be EQUAL."
# Line 412  Line 414 
414  ;;; EQUALP -- public.  ;;; EQUALP -- public.
415  ;;;  ;;;
416  (defun equalp (x y)  (defun equalp (x y)
417    "Just like EQUAL, but more liberal in several respects.    _N"Just like EQUAL, but more liberal in several respects.
418    Numbers may be of different types, as long as the values are identical    Numbers may be of different types, as long as the values are identical
419    after coercion.  Characters may differ in alphabetic case.  Vectors and    after coercion.  Characters may differ in alphabetic case.  Vectors and
420    arrays must have identical dimensions and EQUALP elements, but may differ    arrays must have identical dimensions and EQUALP elements, but may differ

Legend:
Removed from v.1.62  
changed lines
  Added in v.1.62.2.2

  ViewVC Help
Powered by ViewVC 1.1.5