Changeset 7950


Ignore:
Timestamp:
Dec 26, 2007, 8:01:18 AM (12 years ago)
Author:
gb
Message:

Continue Bill's changes to remove brain-death from %%TYPEP on arrays
(we're allowed to make this implementation-dependent.)

Split up many cases of %%TYPEP into separate functions. Make little
functions for type-predicates, not closures.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-typesys.lisp

    r7924 r7950  
    26302630            complexp
    26312631            element-type
    2632             specialized-element-type))
     2632            specialized-element-type
     2633            (unless (eq specialized-element-type *wild-type*)
     2634              (ctype-subtype specialized-element-type))))
    26332635
    26342636(defun array-ctype-p (x) (istruct-typep x 'array-ctype))
     
    28352837
    28362838(defun specialize-array-type (type)
    2837   (let ((eltype (array-ctype-element-type type)))
     2839  (let* ((eltype (array-ctype-element-type type))
     2840         (specialized-type (if (eq eltype *wild-type*)
     2841                             *wild-type*
     2842                             (dolist (stype-name specialized-array-element-types
     2843                                      *universal-type*)
     2844                               (let ((stype (specifier-type stype-name)))
     2845                                 (when (csubtypep eltype stype)
     2846                                   (return stype)))))))
    28382847   
    2839     (setf (array-ctype-specialized-element-type type)
    2840           (if (eq eltype *wild-type*)
    2841               *wild-type*
    2842               (dolist (stype-name specialized-array-element-types
    2843                        *universal-type*)
    2844                 (let ((stype (specifier-type stype-name)))
    2845                   (when (csubtypep eltype stype)
    2846                     (return stype))))))
    2847    
     2848    (setf (array-ctype-specialized-element-type type) specialized-type
     2849          (array-ctype-typecode type) (unless (eq specialized-type *wild-type*)
     2850                                        (ctype-subtype specialized-type)))
    28482851    type))
    28492852
     
    35923595             (specifier-type specifier))))
    35933596
     3597(eval-when (:compile-toplevel)
     3598  (declaim (inline numeric-%%typep
     3599                   array-%%typep
     3600                   member-%%typep
     3601                   cons-%%typep)))
     3602
     3603(defun numeric-%%typep (object type)
     3604  (let ((pred (numeric-ctype-predicate type)))
     3605    (if pred
     3606      (funcall pred object)
     3607      (and (numberp object)
     3608           (let ((num (if (complexp object) (realpart object) object)))
     3609             (ecase (numeric-ctype-class type)
     3610               (integer (integerp num))
     3611               (rational (rationalp num))
     3612               (float
     3613                (ecase (numeric-ctype-format type)
     3614                  (single-float (typep num 'single-float))
     3615                  (double-float (typep num 'double-float))
     3616                  ((nil) (floatp num))))
     3617               ((nil) t)))
     3618           (flet ((bound-test (val)
     3619                    (let ((low (numeric-ctype-low type))
     3620                          (high (numeric-ctype-high type)))
     3621                      (and (cond ((null low) t)
     3622                                 ((listp low) (> val (car low)))
     3623                                 (t (>= val low)))
     3624                           (cond ((null high) t)
     3625                                 ((listp high) (< val (car high)))
     3626                                 (t (<= val high)))))))
     3627             (ecase (numeric-ctype-complexp type)
     3628               ((nil) t)
     3629               (:complex
     3630                (and (complexp object)
     3631                     (bound-test (realpart object))
     3632                     (bound-test (imagpart object))))
     3633               (:real
     3634                (and (not (complexp object))
     3635                     (bound-test object)))))))))
     3636
     3637(defun array-%%typep (object type)
     3638  (let* ((typecode (typecode object)))
     3639    (declare (type (unsigned-byte 8) typecode))
     3640    (and (>= typecode target::subtag-arrayH)
     3641         (ecase (array-ctype-complexp type)
     3642           ((t) (not (simple-array-p object)))
     3643           ((nil) (simple-array-p object))
     3644           ((* :maybe) t))
     3645         (let* ((ctype-dimensions (array-ctype-dimensions type))
     3646                (header-p (= typecode target::subtag-arrayH)))
     3647           (or (eq (array-ctype-dimensions type) '*)
     3648               (and (null (cdr ctype-dimensions)) (not header-p))
     3649               (and header-p
     3650                    (let* ((rank (%svref object target::arrayH.rank-cell)))
     3651                      (declare (fixnum rank))
     3652                      (and (= rank (length ctype-dimensions))
     3653                           (do* ((i 0 (1+ i))
     3654                                 (dim target::arrayH.dim0-cell (1+ dim))
     3655                                 (want (array-ctype-dimensions type) (cdr want))
     3656                                 (got (%svref object dim) (%svref object dim)))
     3657                                ((= i rank) t)
     3658                             (unless (or (eq (car want) '*)
     3659                                         (= (car want) got))
     3660                               (return nil)))))))
     3661           (or (eq (array-ctype-element-type type) *wild-type*)
     3662               (eql (array-ctype-typecode type)
     3663                    (if (> typecode target::subtag-vectorH)
     3664                      typecode
     3665                      (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref object target::arrayH.flags-cell)))))
     3666               (type= (array-ctype-specialized-element-type type)
     3667                      (specifier-type (array-element-type object))))))))
     3668
     3669
     3670(defun member-%%typep (object type)
     3671  (not (null (member object (member-ctype-members type)))))
     3672
     3673(defun cons-%%typep (object type)
     3674  (and (consp object)
     3675       (%%typep (car object) (cons-ctype-car-ctype type))
     3676       (%%typep (cdr object) (cons-ctype-cdr-ctype type))))
     3677
    35943678
    35953679(defun %%typep (object type)
     
    36023686         ((nil) nil)))
    36033687      (numeric-ctype
    3604        (let ((pred (numeric-ctype-predicate type)))
    3605          (if Pred
    3606            (funcall pred object)
    3607            (and (numberp object)
    3608                 (let ((num (if (complexp object) (realpart object) object)))
    3609                   (ecase (numeric-ctype-class type)
    3610                     (integer (integerp num))
    3611                     (rational (rationalp num))
    3612                     (float
    3613                      (ecase (numeric-ctype-format type)
    3614                        (single-float (typep num 'single-float))
    3615                        (double-float (typep num 'double-float))
    3616                        ((nil) (floatp num))))
    3617                     ((nil) t)))
    3618                 (flet ((bound-test (val)
    3619                          (let ((low (numeric-ctype-low type))
    3620                                (high (numeric-ctype-high type)))
    3621                            (and (cond ((null low) t)
    3622                                       ((listp low) (> val (car low)))
    3623                                       (t (>= val low)))
    3624                                 (cond ((null high) t)
    3625                                       ((listp high) (< val (car high)))
    3626                                       (t (<= val high)))))))
    3627                   (ecase (numeric-ctype-complexp type)
    3628                     ((nil) t)
    3629                     (:complex
    3630                      (and (complexp object)
    3631                           (bound-test (realpart object))
    3632                           (bound-test (imagpart object))))
    3633                     (:real
    3634                      (and (not (complexp object))
    3635                           (bound-test object)))))))))
     3688       (numeric-%%typep object type))
    36363689      (array-ctype
    3637        (and (arrayp object)
    3638             (ecase (array-ctype-complexp type)
    3639               ((t) (not (typep object 'simple-array)))
    3640               ((nil) (typep object 'simple-array))
    3641               ((* :maybe) t))
    3642             (or (eq (array-ctype-dimensions type) '*)
    3643                 (let ((rank (array-rank object)))
    3644                   (declare (fixnum rank))
    3645                   (do* ((n 0 (1+ n))
    3646                         (want (array-ctype-dimensions type) (cdr want))
    3647                         (got (and (< n rank) (array-dimension object n))
    3648                              (and (< n rank) (array-dimension object n))))
    3649                        ((and (null want) (null got)) t)
    3650                     (declare (fixnum n))
    3651                     (unless (and want got
    3652                                  (or (eq (car want) '*)
    3653                                      (= (car want) got)))
    3654                       (return nil)))))
    3655             (or (eq (array-ctype-element-type type) *wild-type*)
    3656                 (type= (array-ctype-specialized-element-type type)
    3657                        (specifier-type (array-element-type object))))))
     3690       (array-%%typep object type))
    36583691      (member-ctype
    3659        (if (member object (member-ctype-members type)) t))
     3692       (member-%%typep object type))
    36603693      (class-ctype
    36613694       (not (null (class-typep object (class-ctype-class type)))))
     
    36653698           (return t))))
    36663699      (intersection-ctype
    3667        (every (lambda (type) (%%typep object type))
    3668               (intersection-ctype-types type)))
     3700       (dolist (type (intersection-ctype-types type) t)
     3701         (unless (%%typep object type) (return nil))))
    36693702      (cons-ctype
    3670        (and (consp object)
    3671             (%%typep (car object) (cons-ctype-car-ctype type))
    3672             (%%typep (cdr object) (cons-ctype-cdr-ctype type))))
     3703       (cons-%%typep object type))
    36733704      (unknown-ctype
    36743705       ;; Parse it again to make sure it's really undefined.
     
    41414172
    41424173
     4174(defvar *simple-predicate-function-prototype*
     4175  #'(lambda (thing)
     4176      (%%typep thing #.(specifier-type t))))
     4177
     4178(defun make-simple-type-predicate (function datum)
     4179  #+ppc-target
     4180  (gvector :function
     4181           (uvref *simple-predicate-function-prototype* 0)
     4182           datum
     4183           function
     4184           nil
     4185           (dpb 1 $lfbits-numreq 0))
     4186  #+x86-target
     4187  (%clone-x86-function
     4188   *simple-predicate-function-prototype*
     4189   datum
     4190   function
     4191   nil
     4192   (dpb 1 $lfbits-numreq 0)))
     4193
     4194(defun check-ctypep (thing ctype)
     4195  (multiple-value-bind (win sure) (ctypep thing ctype)
     4196    (or win (not sure))))
     4197
     4198
     4199(defun generate-predicate-for-ctype (ctype)
     4200  (typecase ctype
     4201    (numeric-ctype
     4202     (or (numeric-ctype-predicate ctype)
     4203         (make-simple-type-predicate 'numeric-%%typep ctype)))
     4204    (array-ctype
     4205     (make-simple-type-predicate 'array-%%typep ctype))
     4206    (member-ctype
     4207     (make-simple-type-predicate 'member-%%typep ctype))
     4208    (named-ctype
     4209     (case (named-ctype-name ctype)
     4210       ((* t) #'true)
     4211       (t #'false)))
     4212    (cons-ctype
     4213     (make-simple-type-predicate 'cons-%%typep ctype))
     4214    (function-ctype
     4215     #'functionp)
     4216    (class-ctype
     4217     (make-simple-type-predicate 'class-cell-typep (find-class-cell (class-name (class-ctype-class ctype)) t)))
     4218    (t
     4219     (make-simple-type-predicate 'check-ctypep ctype))))
     4220   
     4221       
     4222
     4223   
    41434224
    41444225;;; Ensure that standard EFFECTIVE-SLOT-DEFINITIONs have a meaningful
     
    41524233    (setf (slot-value spec 'type-predicate)
    41534234          (or (and (typep type 'symbol)
     4235                   (not (eq type 't))
    41544236                   (type-predicate type))
    41554237              (handler-case
    41564238                  (let* ((ctype (specifier-type type)))
    4157                     #'(lambda (value)
    4158                         (multiple-value-bind (win sure) (ctypep value ctype)
    4159                           (or (not sure) win))))
     4239                    (unless (eq ctype *universal-type*)
     4240                      (generate-predicate-for-ctype ctype)))
    41604241                (parse-unknown-type (c)
    4161                                     (declare (ignore c))
    4162                                     #'(lambda (value)
    4163                                         ;; If the type's now known, install a new predicate.
    4164                                         (let* ((nowctype (specifier-type type)))
    4165                                           (unless (typep nowctype 'unknown-ctype)
    4166                                             (setf (slot-value spec 'type-predicate)
    4167                                                   #'(lambda (value) (%%typep value nowctype))))
    4168                                           (multiple-value-bind (win sure)
    4169                                               (ctypep value nowctype)
    4170                                             (or (not sure) win))))))))))
    4171 
     4242                   (declare (ignore c))
     4243                   #'(lambda (value)
     4244                       ;; If the type's now known, install a new predicate.
     4245                       (let* ((nowctype (specifier-type type)))
     4246                         (unless (typep nowctype 'unknown-ctype)
     4247                           (setf (slot-value spec 'type-predicate)
     4248                                 (generate-predicate-for-ctype nowctype)))
     4249                         (multiple-value-bind (win sure)
     4250                             (ctypep value nowctype)
     4251                           (or (not sure) win))))))))))
     4252
Note: See TracChangeset for help on using the changeset viewer.