Ignore:
Timestamp:
Jul 3, 2008, 5:01:35 PM (11 years ago)
Author:
gz
Message:

Propagate r9245 + r9338 + r9340 from working-0711 to trunk. Bootstrapping: this requires using an image from r9887 or later

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-typesys.lisp

    r9887 r9892  
    473473                                    lambda-list &body body)
    474474  `(progn
    475      (let* ((fn #'(lambda ,lambda-list ,@body)))
     475     (let* ((fn (nfunction (,class ,method ,@more-methods)
     476                           (lambda ,lambda-list ,@body))))
    476477       ,@(mapcar #'(lambda (method)
    477478                         `(setf (%svref
     
    745746  (type= (constant-ctype-type type1) (constant-ctype-type type2)))
    746747
    747 (def-type-translator constant-argument (type)
    748   (make-constant-ctype :type (specifier-type type)))
     748(def-type-translator constant-argument (type &environment env)
     749  (make-constant-ctype :type (specifier-type type env)))
    749750
    750751
     
    756757;;;
    757758
    758 (defun parse-args-types (lambda-list result)
     759(defun parse-args-types (lambda-list result &optional env)
    759760  (multiple-value-bind (required optional restp rest keyp keys allowp aux)
    760761                           (parse-lambda-list lambda-list)
    761762    (when aux
    762763      (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list))
    763     (setf (args-ctype-required result) (mapcar #'specifier-type required))
    764     (setf (args-ctype-optional result) (mapcar #'specifier-type optional))
    765     (setf (args-ctype-rest result) (if restp (specifier-type rest) nil))
    766     (setf (args-ctype-keyp result) keyp)
    767     (let* ((key-info ()))
    768       (dolist (key keys)
     764    (flet ((parse (spec) (specifier-type spec env)))
     765      (setf (args-ctype-required result) (mapcar #'parse required))
     766      (setf (args-ctype-optional result) (mapcar #'parse optional))
     767      (setf (args-ctype-rest result) (if restp (parse rest) nil))
     768      (setf (args-ctype-keyp result) keyp)
     769      (let* ((key-info ()))
     770        (dolist (key keys)
    769771          (when (or (atom key) (/= (length key) 2))
    770772            (signal-program-error "Keyword type description is not a two-list: ~S." key))
     
    773775              (signal-program-error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list))
    774776            (push (make-key-info :name kwd
    775                                :type (specifier-type (second key))) key-info)))
    776       (setf (args-ctype-keywords result) (nreverse key-info)))
    777     (setf (args-ctype-allowp result) allowp)))
     777                                 :type (parse (second key))) key-info)))
     778        (setf (args-ctype-keywords result) (nreverse key-info)))
     779      (setf (args-ctype-allowp result) allowp))))
    778780
    779781;;; Unparse-Args-Types  --  Internal
     
    808810    (nreverse result)))
    809811
    810 (def-type-translator function (&optional (args '*) (result '*))
     812(def-type-translator function (&optional (args '*) (result '*) &environment env)
    811813  (let ((res (make-function-ctype
    812                 :returns (values-specifier-type result))))
     814                :returns (values-specifier-type result env))))
    813815    (if (eq args '*)
    814816        (setf (function-ctype-wild-args res) t)
    815         (parse-args-types args res))
     817        (parse-args-types args res env))
    816818    res))
    817819
    818 (def-type-translator values (&rest values)
     820(def-type-translator values (&rest values &environment env)
    819821  (let ((res (make-values-ctype)))
    820     (parse-args-types values res)
     822    (parse-args-types values res env)
    821823    (when (or (values-ctype-keyp res) (values-ctype-allowp res))
    822824      (signal-program-error "&KEY or &ALLOW-OTHER-KEYS in values type: ~s"
     
    13311333;;;
    13321334
    1333 (defun values-specifier-type-internal (orig)
     1335(defun values-specifier-type-internal (orig env)
    13341336  (or (info-type-builtin orig) ; this table could contain bytes etal and ands ors nots of built-in types - no classes
    13351337     
    1336       (let ((spec (type-expand orig)))
     1338      ;; Now that we have our hands on the environment, we could pass it into type-expand,
     1339      ;; but we'd have no way of knowing whether the expansion depended on the env, so
     1340      ;; we wouldn't know if the result is safe to cache.   So for now don't let type
     1341      ;; expanders see the env, which just means they won't see compile-time types.
     1342      (let ((spec (type-expand orig #+not-yet env)))
    13371343        (cond
    13381344         ((and (not (eq spec orig))
    13391345               (info-type-builtin spec)))
    1340          ((eq (info-type-kind spec) :instance)
    1341           (let* ((class-ctype (%class.ctype (find-class spec))))
     1346         ((or (eq (info-type-kind spec) :instance)
     1347              (and (symbolp spec)
     1348                   (typep (find-class spec nil env) 'compile-time-class)))
     1349          (let* ((class-ctype (%class.ctype (find-class spec t env))))
    13421350            (or (class-ctype-translation class-ctype)
    13431351                class-ctype)))
     
    13511359          (let* ((lspec (if (atom spec) (list spec) spec))
    13521360                 (fun (info-type-translator (car lspec))))
    1353             (cond (fun (funcall fun lspec nil))
     1361            (cond (fun (funcall fun lspec env))
    13541362                  ((or (and (consp spec) (symbolp (car spec)))
    13551363                       (symbolp spec))
     
    13651373  (defconstant type-cache-size (ash 1 12))
    13661374  (defconstant type-cache-mask (1- type-cache-size)))
     1375
     1376(defun compile-time-ctype-p (ctype)
     1377  (and (typep ctype 'class-ctype)
     1378       (typep (class-ctype-class ctype) 'compile-time-class)))
     1379
    13671380
    13681381;;; We can get in trouble if we try to cache certain kinds of ctypes,
     
    14001413          (cacheable-ctype-p (cons-ctype-cdr-ctype ctype))))
    14011414    (unknown-ctype nil)
     1415    (class-ctype
     1416     (not (typep (class-ctype-class ctype) 'compile-time-class)))
    14021417    ;; Anything else ?  Simple things (numbers, classes) can't lose.
    14031418    (t t)))
     
    14221437    nil)
    14231438
    1424   (defun values-specifier-type (spec)
     1439  (defun values-specifier-type (spec &optional env)
    14251440    (if (typep spec 'class)
    14261441      (let* ((class-ctype (%class.ctype spec)))
    14271442        (or (class-ctype-translation class-ctype) class-ctype))
    14281443      (if locked
    1429         (or (values-specifier-type-internal spec)
     1444        (or (values-specifier-type-internal spec env)
    14301445            (make-unknown-ctype :specifier spec))
    14311446        (unwind-protect
     
    14401455                    (incf hits)
    14411456                    (svref type-cache-ctypes idx))
    1442                   (let* ((ctype (values-specifier-type-internal spec)))
     1457                  (let* ((ctype (values-specifier-type-internal spec env)))
    14431458                    (if ctype
    14441459                      (progn
     
    14481463                        ctype)
    14491464                      (make-unknown-ctype :specifier spec)))))
    1450               (values-specifier-type-internal spec)))
     1465              (values-specifier-type-internal spec env)))
    14511466          (setq locked nil)))))
    14521467 
     
    14701485;;;
    14711486(defun specifier-type (x &optional env)
    1472   (declare (ignore env))
    1473   (let ((res (values-specifier-type x)))
     1487  (let ((res (values-specifier-type x env)))
    14741488    (when (values-ctype-p res)
    14751489      (signal-program-error "VALUES type illegal in this context:~%  ~S" x))
    14761490    res))
    14771491
    1478 (defun single-value-specifier-type (x)
    1479   (let ((res (specifier-type x)))
     1492(defun single-value-specifier-type (x &optional env)
     1493  (let ((res (specifier-type x env)))
    14801494    (if (eq res *wild-type*)
    14811495        *universal-type*
    14821496        res)))
    14831497
    1484 (defun standardized-type-specifier (spec)
    1485   (type-specifier (specifier-type spec)))
     1498(defun standardized-type-specifier (spec &optional env)
     1499  (handler-case
     1500      (type-specifier (specifier-type spec env))
     1501    (parse-unknown-type () spec)))
    14861502
    14871503(defun modified-numeric-type (base
     
    18501866  (type= (negation-ctype-type type1) (negation-ctype-type type2)))
    18511867
    1852 (def-type-translator not (typespec)
    1853   (let* ((not-type (specifier-type typespec))
     1868(def-type-translator not (typespec &environment env)
     1869  (let* ((not-type (specifier-type typespec env))
    18541870         (spec (type-specifier not-type)))
    18551871    (cond
    18561872      ;; canonicalize (NOT (NOT FOO))
    18571873      ((and (listp spec) (eq (car spec) 'not))
    1858        (specifier-type (cadr spec)))
     1874       (specifier-type (cadr spec) env))
    18591875      ;; canonicalize (NOT NIL) and (NOT T)
    18601876      ((eq not-type *empty-type*) *universal-type*)
     
    18951911       (apply #'type-union
    18961912              (mapcar #'(lambda (x)
    1897                           (specifier-type `(not ,(type-specifier x))))
     1913                          (specifier-type `(not ,(type-specifier x)) env))
    18981914                      (intersection-ctype-types not-type))))
    18991915      ((union-ctype-p not-type)
    19001916       (apply #'type-intersection
    19011917              (mapcar #'(lambda (x)
    1902                           (specifier-type `(not ,(type-specifier x))))
     1918                          (specifier-type `(not ,(type-specifier x)) env))
    19031919                      (union-ctype-types not-type))))
    19041920      ((member-ctype-p not-type)
     
    19401956      ((cons-ctype-p not-type)
    19411957       (type-union
    1942         (make-negation-ctype :type (specifier-type 'cons))
     1958        (make-negation-ctype :type (specifier-type 'cons env))
    19431959        (cond
    19441960          ((and (not (eq (cons-ctype-car-ctype not-type) *universal-type*))
     
    19471963            (make-cons-ctype
    19481964             (specifier-type `(not ,(type-specifier
    1949                                      (cons-ctype-car-ctype not-type))))
     1965                                     (cons-ctype-car-ctype not-type))) env)
    19501966             *universal-type*)
    19511967            (make-cons-ctype
    19521968             *universal-type*
    19531969             (specifier-type `(not ,(type-specifier
    1954                                      (cons-ctype-cdr-ctype not-type)))))))
     1970                                     (cons-ctype-cdr-ctype not-type))) env))))
    19551971          ((not (eq (cons-ctype-car-ctype not-type) *universal-type*))
    19561972           (make-cons-ctype
    19571973            (specifier-type `(not ,(type-specifier
    1958                                     (cons-ctype-car-ctype not-type))))
     1974                                    (cons-ctype-car-ctype not-type))) env)
    19591975            *universal-type*))
    19601976          ((not (eq (cons-ctype-cdr-ctype not-type) *universal-type*))
     
    19621978            *universal-type*
    19631979            (specifier-type `(not ,(type-specifier
    1964                                     (cons-ctype-cdr-ctype not-type))))))
     1980                                    (cons-ctype-cdr-ctype not-type))) env)))
    19651981          (t (error "Weird CONS type ~S" not-type)))))
    19661982      (t (make-negation-ctype :type not-type)))))
     
    23032319      (info-type-builtin 'number) (make-numeric-ctype :complexp nil))
    23042320
    2305 (def-type-translator complex (&optional spec)
     2321(def-type-translator complex (&optional spec &environment env)
    23062322  (if (eq spec '*)
    23072323      (make-numeric-ctype :complexp :complex)
     
    23422358                   (t                   ; punt on harder stuff for now
    23432359                    (not-real)))))
    2344         (let ((ctype (specifier-type spec)))
     2360        (let ((ctype (specifier-type spec env)))
    23452361          (do-complex ctype)))))
    23462362
     
    28222838                           dims))))
    28232839
    2824 (def-type-translator array (&optional element-type dimensions)
     2840(def-type-translator array (&optional element-type dimensions &environment env)
    28252841  (specialize-array-type
    28262842   (make-array-ctype :dimensions (check-array-dimensions dimensions)
    28272843                     :complexp :maybe
    2828                      :element-type (specifier-type element-type))))
    2829 
    2830 (def-type-translator simple-array (&optional element-type dimensions)
     2844                     :element-type (specifier-type element-type env))))
     2845
     2846(def-type-translator simple-array (&optional element-type dimensions &environment env)
    28312847  (specialize-array-type
    28322848   (make-array-ctype :dimensions (check-array-dimensions dimensions)
    2833                          :element-type (specifier-type element-type)
     2849                         :element-type (specifier-type element-type env)
    28342850                         :complexp nil)))
    28352851
     
    31053121
    31063122
    3107 (def-type-translator or (&rest type-specifiers)
     3123(def-type-translator or (&rest type-specifiers &environment env)
    31083124  (apply #'type-union
    3109          (mapcar #'specifier-type type-specifiers)))
     3125         (mapcar #'(lambda (spec) (specifier-type spec env)) type-specifiers)))
    31103126
    31113127
     
    32083224                     (type-intersection accumulator union))))))))
    32093225
    3210 (def-type-translator and (&rest type-specifiers)
     3226(def-type-translator and (&rest type-specifiers &environment env)
    32113227  (apply #'type-intersection
    3212          (mapcar #'specifier-type
     3228         (mapcar #'(lambda (spec) (specifier-type spec env))
    32133229                 type-specifiers)))
    32143230
     
    32343250(setf (type-predicate 'cons-ctype) 'cons-ctype-p)
    32353251 
    3236 (def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
    3237   (make-cons-ctype (specifier-type car-type-spec)
    3238                    (specifier-type cdr-type-spec)))
     3252(def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*) &environment env)
     3253  (make-cons-ctype (specifier-type car-type-spec env)
     3254                   (specifier-type cdr-type-spec env)))
    32393255
    32403256(define-type-method (cons :unparse) (type)
     
    34223438      (if (memq class2 (class-direct-superclasses class1))
    34233439        (values t t)
    3424         (if (class-has-a-forward-referenced-superclass-p class1)
     3440        (if (or (class-has-a-forward-referenced-superclass-p class1)
     3441                (typep class1 'compile-time-class))
    34253442          (values nil nil)
    34263443          (let ((supers (%inited-class-cpl class1)))
     
    34463463  (let* ((class1 (if (class-ctype-p type1) (class-ctype-class type1)))
    34473464         (class2 (if (class-ctype-p type2) (class-ctype-class type2))))
    3448     (if (and class1 class2)
     3465    (if (and class1
     3466             (not (typep class1 'compile-time-class))
     3467             class2
     3468             (not (typep class2 'compile-time-class)))
    34493469      (cond ((subclassp class1 class2)
    34503470             type1)
Note: See TracChangeset for help on using the changeset viewer.