Changeset 9892


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

Location:
trunk/source
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/nx0.lisp

    r9879 r9892  
    23792379  (setq type (nx-target-type (type-expand type)))
    23802380  (if (constantp arg)
    2381     (typep (nx-unquote arg) type)
    2382     (subtypep (nx-form-type arg env) type)))
     2381    (typep (nx-unquote arg) type env)
     2382    (subtypep (nx-form-type arg env) type env)))
    23832383
    23842384
  • trunk/source/compiler/optimizers.lisp

    r9058 r9892  
    22;;;
    33;;;   Copyright (C) 1994-2001 Digitool, Inc
    4 ;;;   This file is part of OpenMCL. 
     4;;;   This file is part of OpenMCL.
    55;;;
    66;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
     
    88;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
    99;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
    10 ;;;   conflict, the preamble takes precedence. 
     10;;;   conflict, the preamble takes precedence.
    1111;;;
    1212;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
     
    5858    (let* ((bits (%symbol-bits name)))
    5959      (declare (fixnum bits))
    60       (%symbol-bits name (logior 
     60      (%symbol-bits name (logior
    6161                          (if handler (logior (ash 1 $sym_fbit_fold_subforms) (ash 1 $sym_fbit_constant_fold))
    6262                              (ash 1 $sym_fbit_constant_fold))
     
    118118              (push arg targs)
    119119              (return)))
    120         (return 
     120        (return
    121121         (fixnumify (nreverse targs) op))))
    122122    call))
     
    144144                            keys
    145145          (declare (ignore test-not))
    146           (if (and test-p 
     146          (if (and test-p
    147147                   (not test-not-p)
    148148                   (or (not key-p)
     
    153153                                (eq (%car key) 'quote))
    154154                            (eq (%cadr key) 'identity)))
    155                    (consp test) 
     155                   (consp test)
    156156                   (consp (%cdr test))
    157157                   (null (%cddr test))
     
    203203        (let* ((op (car call))
    204204               (constant (if (cdr constants) (handler-case (apply op constants)
    205                                                (error (c) (declare (ignore c)) 
     205                                               (error (c) (declare (ignore c))
    206206                                                      (return-from fold-constant-subforms (values call t))))
    207207                             (car constants))))
     
    256256;;;
    257257;;; The new (roughly alphabetical) order.
    258 ;;; 
     258;;;
    259259;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    260260
     
    302302  `(+ ,x 1))
    303303
    304 (define-compiler-macro append  (&whole call 
    305                                        &optional arg0 
    306                                        &rest 
    307                                        (&whole tail 
    308                                                &optional (junk nil arg1-p) 
     304(define-compiler-macro append  (&whole call
     305                                       &optional arg0
     306                                       &rest
     307                                       (&whole tail
     308                                               &optional (junk nil arg1-p)
    309309                                               &rest more))
    310310  ;(append (list x y z) A) -> (list* x y z A)
     
    338338        (apply (class-cell-instantiate ,class-cell) ,class-cell ,@args)))
    339339    (let ((original-fn fn))
    340       (if (and arg0 
     340      (if (and arg0
    341341               (null args)
    342342               (consp fn)
     
    368368    `(asseql ,item ,list)
    369369    call))
    370  
     370
    371371(define-compiler-macro asseql (&whole call &environment env item list)
    372372  (if (or (eql-iff-eq-p item env)
     
    424424(define-compiler-macro caaaar (form)
    425425  `(car (caaar ,form)))
    426  
     426
    427427(define-compiler-macro caaadr (form)
    428428  `(car (caadr ,form)))
     
    448448(define-compiler-macro cdaaar (form)
    449449  `(cdr (caaar ,form)))
    450  
     450
    451451(define-compiler-macro cdaadr (form)
    452452  `(cdr (caadr ,form)))
     
    492492     call))
    493493
    494 (define-compiler-macro dotimes (&whole call (i n &optional result) 
     494(define-compiler-macro dotimes (&whole call (i n &optional result)
    495495                                       &body body
    496496                                       &environment env)
     
    547547      (multiple-value-bind (false false-win) (nx-transform false env)
    548548        (if (or (quoted-form-p test) (self-evaluating-p test))
    549           (if (eval test) 
     549          (if (eval test)
    550550            true
    551551            false)
     
    626626      `(progn ,@body))))
    627627
    628 
    629 (defun target-element-type-type-keyword (typespec)
    630   (let* ((ctype (ignore-errors (specifier-type `(array ,typespec)))))
    631     (if (or (null ctype) (typep ctype 'unknown-ctype))
     628(defun specifier-type-if-known (typespec &optional env)
     629  (handler-case (specifier-type typespec env)
     630    (parse-unknown-type (c) (values nil (parse-unknown-type-specifier c)))
     631    (error () nil)))
     632
     633#+debugging-version
     634(defun specifier-type-if-known (typespec &optional env)
     635  (handler-bind ((parse-unknown-type (lambda (c)
     636                                       (break "caught unknown-type ~s" c)
     637                                       (return-from specifier-type-if-known
     638                                         (values nil (parse-unknown-type-specifier c)))))
     639                 (error (lambda (c)
     640                          (break "caught error ~s" c)
     641                          (return-from specifier-type-if-known nil))))
     642    (specifier-type typespec env)))
     643
     644
     645(defun target-element-type-type-keyword (typespec &optional env)
     646  (let* ((ctype (specifier-type-if-known `(array ,typespec) env)))
     647    (if (null ctype)
    632648      (progn
    633649        (nx1-whine :unknown-type-declaration typespec)
     
    667683          (setf (array-ctype-dimensions ctype)
    668684                '*))))
    669     (let* ((element-type (specifier-type (if element-type-p (nx-unquote element-type) t))))
     685    (let* ((typespec (if element-type-p (nx-unquote element-type) t))
     686           (element-type (or (specifier-type-if-known typespec env)
     687                             (make-unknown-ctype :specifier typespec))))
    670688      (setf (array-ctype-element-type ctype) element-type)
    671689      (if (typep element-type 'unknown-ctype)
     
    674692    (type-specifier ctype)))
    675693
    676      
    677      
     694
     695
    678696(define-compiler-macro make-array (&whole call &environment env dims &rest keys)
    679697  (if (constant-keywords-p keys)
     
    684702                              (fill-pointer () fill-pointer-p)
    685703                              (initial-element () initial-element-p)
    686                               (initial-contents () initial-contents-p)) 
     704                              (initial-contents () initial-contents-p))
    687705        keys
    688706      (declare (ignorable element-type element-type-p
     
    694712                          initial-contents initial-contents-p))
    695713      (let* ((element-type-keyword nil)
    696              (expansion 
     714             (expansion
    697715              (cond ((and initial-element-p initial-contents-p)
    698716                     (nx1-whine 'illegal-arguments call)
     
    702720                       (comp-make-array-1 dims keys)
    703721                       (comp-make-displaced-array dims keys)))
    704                     ((or displaced-index-offset-p 
     722                    ((or displaced-index-offset-p
    705723                         (not (constantp element-type))
    706724                         (null (setq element-type-keyword
    707725                                     (target-element-type-type-keyword
    708                                       (eval element-type)))))
     726                                      (eval element-type) env))))
    709727                     (comp-make-array-1 dims keys))
    710                     ((and (typep element-type-keyword 'keyword) 
    711                           (nx-form-typep dims 'fixnum env) 
    712                           (null (or adjustable fill-pointer initial-contents 
    713                                     initial-contents-p))) 
    714                      (if 
    715                        (or (null initial-element-p) 
    716                            (cond ((eql element-type-keyword :double-float-vector) 
    717                                   (eql initial-element 0.0d0)) 
    718                                  ((eql element-type-keyword :single-float-vector) 
    719                                   (eql initial-element 0.0s0)) 
    720                                  ((eql element-type :simple-string) 
     728                    ((and (typep element-type-keyword 'keyword)
     729                          (nx-form-typep dims 'fixnum env)
     730                          (null (or adjustable fill-pointer initial-contents
     731                                    initial-contents-p)))
     732                     (if
     733                       (or (null initial-element-p)
     734                           (cond ((eql element-type-keyword :double-float-vector)
     735                                  (eql initial-element 0.0d0))
     736                                 ((eql element-type-keyword :single-float-vector)
     737                                  (eql initial-element 0.0s0))
     738                                 ((eql element-type :simple-string)
    721739                                  (eql initial-element #\Null))
    722740                                 (t (eql initial-element 0))))
    723                        `(allocate-typed-vector ,element-type-keyword ,dims) 
    724                        `(allocate-typed-vector ,element-type-keyword ,dims ,initial-element))) 
     741                       `(allocate-typed-vector ,element-type-keyword ,dims)
     742                       `(allocate-typed-vector ,element-type-keyword ,dims ,initial-element)))
    725743                    (t                        ;Should do more here
    726744                     (comp-make-uarray dims keys (type-keyword-code element-type-keyword)))))
    727745             (type (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)))
    728746        `(the ,type ,expansion)))
    729        
     747
    730748        call))
    731749
     
    762780  (let* ((call-list (make-list 10 :initial-element nil))
    763781         (dims-var (make-symbol "DIMS"))
    764          (let-list (comp-nuke-keys keys                                   
     782         (let-list (comp-nuke-keys keys
    765783                                   '((:element-type 0 1)
    766784                                     (:displaced-to 2)
     
    808826
    809827
    810                                  
     828
    811829
    812830(define-compiler-macro mapc  (&whole call fn lst &rest more)
     
    848866    `(memeql ,item ,list)
    849867    call))
    850  
     868
    851869(define-compiler-macro memeql (&whole call &environment env item list)
    852870  (if (or (eql-iff-eq-p item env)
     
    893911  (if (and (fixnump count)
    894912           (%i>= count 0)
    895            (%i< count 4)) 
     913           (%i< count 4))
    896914     (if (%izerop count)
    897915       `(require-type ,list 'list)
     
    918936;;; optimizers... For now, at least try to get it to become (%car
    919937;;; (<typecheck> foo)).
    920 (define-compiler-macro require-type (&whole call &environment env arg type)
     938(define-compiler-macro require-type (&whole call &environment env arg type &aux ctype)
    921939  (cond ((and (or (eq type t)
    922940                  (and (quoted-form-p type)
    923941                       (setq type (%cadr type))))
    924               (not (typep (specifier-type type) 'unknown-ctype)))       
     942              (setq ctype (specifier-type-if-known type env)))
    925943         (cond ((nx-form-typep arg type env) arg)
    926944               ((eq type 'simple-vector)
     
    942960               ((eq type 'symbol)
    943961                `(the symbol (require-symbol ,arg)))
    944                ((type= (specifier-type type)
     962               ((type= ctype
    945963                       (specifier-type '(signed-byte 8)))
    946                 `(the (signed-byte 8) (require-s8 ,arg)))               
    947                ((type= (specifier-type type)
     964                `(the (signed-byte 8) (require-s8 ,arg)))
     965               ((type= ctype
    948966                       (specifier-type '(unsigned-byte 8)))
    949967                `(the (unsigned-byte 8) (require-u8 ,arg)))
    950                ((type= (specifier-type type)
     968               ((type= ctype
    951969                       (specifier-type '(signed-byte 16)))
    952970                `(the (signed-byte 16) (require-s16 ,arg)))
    953                ((type= (specifier-type type)
     971               ((type= ctype
    954972                       (specifier-type '(unsigned-byte 16)))
    955                 `(the (unsigned-byte 16) (require-u16 ,arg)))               
    956                ((type= (specifier-type type)
     973                `(the (unsigned-byte 16) (require-u16 ,arg)))
     974               ((type= ctype
    957975                       (specifier-type '(signed-byte 32)))
    958976                `(the (signed-byte 32) (require-s32 ,arg)))
    959                ((type= (specifier-type type)
     977               ((type= ctype
    960978                       (specifier-type '(unsigned-byte 32)))
    961979                `(the (unsigned-byte 32) (require-u32 ,arg)))
    962                ((type= (specifier-type type)
     980               ((type= ctype
    963981                       (specifier-type '(signed-byte 64)))
    964982                `(the (signed-byte 64) (require-s64 ,arg)))
    965                ((type= (specifier-type type)
     983               ((type= ctype
    966984                       (specifier-type '(unsigned-byte 64)))
    967985                `(the (unsigned-byte 64) (require-u64 ,arg)))
     
    11631181                 (dolist (,elt-var ,sequence (%cdr ,result-var))
    11641182                   (,loop-test (funcall ,test (funcall ,key ,elt-var))
    1165                                (setq ,temp-var 
    1166                                      (%cdr 
     1183                               (setq ,temp-var
     1184                                     (%cdr
    11671185                                      (%rplacd ,temp-var (list ,elt-var)))))))))
    11681186          call))
     
    12831301    `(not (logbitp 0 (the fixnum ,n0)))
    12841302    w))
    1285  
     1303
    12861304
    12871305(define-compiler-macro logandc2 (n0 n1)
     
    13231341              `(require-type ,n0 'integer)
    13241342              identity)))))))
    1325          
     1343
    13261344(define-compiler-macro logand (&whole w &rest all)
    13271345  (declare (ignore all))
     
    13461364    `(not (eql 0 (logand ,n1 ,n2)))
    13471365    w))
    1348  
     1366
    13491367
    13501368(defmacro defsynonym (from to)
     
    13531371     (setf (compiler-macro-function ',from) nil)
    13541372     (let ((pair (assq ',from *nx-synonyms*)))
    1355        (if pair (rplacd pair ',to) 
    1356            (push (cons ',from ',to) 
     1373       (if pair (rplacd pair ',to)
     1374           (push (cons ',from ',to)
    13571375                 *nx-synonyms*))
    13581376       ',to)))
     
    14811499        `(array-%%typep ,thing ,ctype))))))
    14821500
    1483                              
    1484  
     1501
     1502
    14851503(defun optimize-typep (thing type env)
    14861504  ;; returns a new form, or nil if it can't optimize
    1487   (let* ((ctype (ignore-errors (specifier-type type))))
    1488     (when (and ctype (not (typep ctype 'unknown-ctype)))
     1505  (let* ((ctype (specifier-type-if-known type env)))
     1506    (when ctype
    14891507      (let* ((type (type-specifier ctype))
    14901508             (predicate (if (typep type 'symbol) (type-predicate type))))
     
    15091527                           (t nil)))
    15101528                    ((consp type)
    1511                      (cond 
     1529                     (cond
    15121530                       ((info-type-builtin type) ; byte types
    15131531                        `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1514                        (t 
     1532                       (t
    15151533                        (case (%car type)
    15161534                          (satisfies `(funcall ',(cadr type) ,thing))
     
    15321550
    15331551(define-compiler-macro typep  (&whole call &environment env thing type &optional e)
    1534   (declare (ignore e))
    15351552  (if (quoted-form-p type)
    1536     (if (constantp thing)
    1537       (typep (if (quoted-form-p thing) (%cadr thing) thing) (%cadr type))
    1538       (or (optimize-typep thing (%cadr type) env)
     1553    (if (and (constantp thing) (specifier-type-if-known type env))
     1554      (typep (if (quoted-form-p thing) (%cadr thing) thing) (%cadr type) env)
     1555      (or (and (null e) (optimize-typep thing (%cadr type) env))
    15391556          call))
    15401557    (if (eq type t)
     
    16851702
    16861703
    1687                        
     1704
    16881705(defsynonym %get-unsigned-byte %get-byte)
    16891706(defsynonym %get-unsigned-word %get-word)
     
    17891806(define-compiler-macro aref (&whole call a &rest subscripts &environment env)
    17901807  (let* ((ctype (if (nx-form-typep a 'array env)
    1791                   (specifier-type (nx-form-type a env))))
     1808                  (specifier-type (nx-form-type a env) env)))
    17921809         (type (if ctype (type-specifier (array-ctype-specialized-element-type ctype))))
    17931810         (useful (unless (or (eq type *) (eq type t))
    1794                    type))) 
     1811                   type)))
    17951812    (if (= 2 (length subscripts))
    17961813      (setq call `(%aref2 ,a ,@subscripts))
     
    18681885
    18691886
     1887
    18701888(defsetf %misc-ref %misc-set)
    1871 
    18721889
    18731890(define-compiler-macro lockp (lock)
     
    18751892    `(eq ,tag (typecode ,lock))))
    18761893
    1877 
    1878 (define-compiler-macro integerp (thing) 
     1894(define-compiler-macro integerp (thing)
    18791895  (let* ((typecode (gensym))
    18801896         (fixnum-tag (arch::target-fixnum-tag (backend-target-arch *target-backend*)))
     
    18851901        t
    18861902        (= ,typecode ,bignum-tag)))))
    1887        
     1903
    18881904(define-compiler-macro %composite-pointer-ref (size pointer offset)
    18891905  (if (constantp size)
     
    19852001
    19862002(define-compiler-macro float (&whole call number &optional (other 0.0f0 other-p) &environment env)
    1987  
     2003
    19882004  (cond ((and (typep other 'single-float)
    19892005              (nx-form-typep number 'double-float env))
  • 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)
  • trunk/source/level-1/sysutils.lisp

    r9848 r9892  
    295295(defun typep (object type &optional env)
    296296  "Is OBJECT of type TYPE?"
    297   (declare (ignore env))
    298297  (let* ((pred (if (symbolp type) (type-predicate type))))
    299298    (if pred
    300299      (funcall pred object)
    301       (values (%typep object type)))))
     300      (values (%typep object (if env (specifier-type type env) type))))))
    302301
    303302
     
    342341
    343342(defun subtypep (type1 type2 &optional env)
    344   (declare (ignore env))
    345343  "Return two values indicating the relationship between type1 and type2.
    346344  If values are T and T, type1 definitely is a subtype of type2.
    347345  If values are NIL and T, type1 definitely is not a subtype of type2.
    348346  If values are NIL and NIL, it couldn't be determined."
    349   (csubtypep (specifier-type type1) (specifier-type type2)))
     347  (csubtypep (specifier-type type1 env) (specifier-type type2 env)))
    350348
    351349
  • trunk/source/lib/nfcomp.lisp

    r9887 r9892  
    2929(require 'backquote)
    3030(require 'defstruct-macros)
    31 
    3231
    3332(defmacro short-fixnum-p (fixnum)
     
    145144                            :report (lambda (stream) (format stream "Skip compiling ~s" src))
    146145                            (return))))))
    147 
    148146
    149147(defun %compile-file (src output-file verbose print load features
     
    777775  (let ((defenv (definition-environment env)))
    778776    (when defenv
     777      (when (non-nil-symbolp (sd-name sd))
     778        (push (make-instance 'compile-time-class :name (sd-name sd))
     779              (defenv.classes defenv)))
    779780      (setf (defenv.structures defenv) (alist-adjoin (sd-name sd) sd (defenv.structures defenv)))
    780781      (let* ((structrefs (defenv.structrefs defenv)))
Note: See TracChangeset for help on using the changeset viewer.