Changeset 12045


Ignore:
Timestamp:
May 13, 2009, 5:52:49 PM (10 years ago)
Author:
gz
Message:

Extend the mechanism used to warn about undefined and duplicate functions in a
compilation unit to do the same for types, use it for types defined by
deftype/defstruct/defclass.

Also make proclaim-type err on invalid types and warn about undefined ones.

Tighten up assorted type/ftype declaration checking. This in turn unleashed
a bunch of test suite tests requiring errors on conflicts between DECLARATION
declarations and types, so I put in checks for those as well.

Location:
trunk/source
Files:
17 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/nx-basic.lisp

    r11901 r12045  
    4242
    4343(defvar *nx-current-code-note*)
     44
     45;; The problem with undefind type warnings is that there is no in-language way to shut
     46;; them up even when the reference is intentional.  (In case of undefined functions,
     47;; you can declare FTYPE and that will turn off any warnings without interfering with
     48;; the function being defined later).  For now just provide this as an out.
     49(defvar *compiler-warn-on-undefined-type-references* #+ccl-0711 t #-ccl-0711 t)
     50
     51
    4452
    4553;; In lieu of a slot in acode.  Don't reference this variable elsewhere because I'm
     
    574582    (:ignore . "Variable ~S not ignored.")
    575583    (:undefined-function . "Undefined function ~S")
     584    (:undefined-type . "Undefined type ~S")
    576585    (:unknown-declaration . "Unknown declaration ~S")
    577     (:unknown-type-declaration . "Unknown type ~S")
     586    (:invalid-type . report-invalid-type-compiler-warning)
    578587    (:unknown-declaration-variable . "~s declaration for unknown variable ~s")
    579588    (:macro-used-before-definition . "Macro function ~S was used before it was defined.")
     
    592601    (:unsure . "Nonspecific warning")))
    593602
     603(defun report-invalid-type-compiler-warning (condition stream)
     604  (destructuring-bind (type &optional why) (compiler-warning-args condition)
     605    (when (typep why 'invalid-type-specifier)
     606      (setq type (invalid-type-specifier-typespec why) why nil))
     607    (format stream "Invalid type specifier ~S~@[: ~A~]" type why)))
     608
    594609(defun report-compile-time-duplicate-definition (condition stream)
    595610  (destructuring-bind (name old-file new-file &optional from to) (compiler-warning-args condition)
     
    619634    (if (typep format-string 'string)
    620635      (apply #'format stream format-string (adjust-compiler-warning-args warning-type (compiler-warning-args condition)))
    621       (funcall format-string condition stream))
     636      (if (null format-string)
     637        (format stream "~A: ~S" warning-type (compiler-warning-args condition))
     638        (funcall format-string condition stream)))
    622639    ;(format stream ".")
    623640    (let ((nrefs (compiler-warning-nrefs condition)))
  • trunk/source/compiler/nx.lisp

    r11805 r12045  
    139139    lfun))
    140140
     141#-BOOTSTRAPPED (unless (find-class 'undefined-reference nil)
     142                 (deftype undefined-reference () 'undefined-function-reference)
     143                 (defclass undefined-type-reference (undefined-function-reference) ()))
     144
    141145(defun signal-or-defer-warnings (warnings env)
    142146  (let* ((defenv (definition-environment env))
     
    144148         (defer (and defenv (cdr (defenv.type defenv)) *outstanding-deferred-warnings*)))
    145149    (dolist (w warnings)
    146       (if (and defer (typep w 'undefined-function-reference))
     150      (if (and defer (typep w 'undefined-reference))
    147151        (push w (deferred-warnings.warnings defer))
    148152        (progn
     
    198202(defparameter *compiler-whining-conditions*
    199203  '((:undefined-function . undefined-function-reference)
     204    (:undefined-type . undefined-type-reference)
     205    (:invalid-type . invalid-type-warning)
    200206    (:global-mismatch . invalid-arguments-global)
    201207    (:lexical-mismatch . invalid-arguments)
  • trunk/source/compiler/nx0.lisp

    r12038 r12045  
    366366    (dolist (spec (%cdr decl))
    367367      (if (memq (setq s (car spec)) *nx-known-declarations*)
     368        ;;  Hmm, NOTSPECIAL and FUNCTION are in *nx-known-declarations* but have no standard handler.
    368369        (if (setq f (getf *nx-standard-declaration-handlers* s))
    369370          (funcall f pending spec env))
    370371        ; Any type name is now (ANSI CL) a valid declaration.
    371         ; We should probably do something to distinguish "type names" from "typo names",
    372         ; so that (declare (inliMe foo)) warns unless the compiler has some reason to
    373         ; believe that 'inliMe' (inlemon) has been DEFTYPEd.
    374         (dolist (var (%cdr spec))
    375           (if (symbolp var)
    376             (nx-new-vdecl pending var 'type s)))))))
     372        (if (symbolp s)
     373          (nx-process-type-decl pending spec s (%cdr spec) env)
     374          (nx-bad-decls spec))))))
    377375
    378376; Put all variable decls for the symbol VAR into effect in environment ENV.  Now.
     
    685683           (%cadr acode-expression)))))
    686684
     685(defun specifier-type-if-known (typespec &optional env &key whine)
     686  (handler-case (specifier-type typespec env)
     687    (parse-unknown-type (c)
     688      (when (and whine *compiler-warn-on-undefined-type-references*)
     689        (nx1-whine :undefined-type (parse-unknown-type-specifier c)))
     690      (values nil (parse-unknown-type-specifier c)))
     691    ;; catch any errors due to destructuring in type-expand
     692    (program-error (c)
     693      (when whine
     694        (nx1-whine :invalid-type typespec c))
     695      (values nil typespec))))
     696
     697#+debugging-version
     698(defun specifier-type-if-known (typespec &optional env &key whine)
     699  (handler-bind ((parse-unknown-type (lambda (c)
     700                                       (break "caught unknown-type ~s" c)
     701                                       (when (and whine *compiler-warn-on-undefined-type-references*)
     702                                         (nx1-whine :undefined-type (parse-unknown-type-specifier c)))
     703                                       (return-from specifier-type-if-known
     704                                         (values nil (parse-unknown-type-specifier c)))))
     705                 (program-error (lambda (c)
     706                                  (break "caught program-error ~s" c)
     707                                  (when whine
     708                                    (nx1-whine :invalid-type typespec c))
     709                                  (return-from specifier-type-if-known
     710                                    (values nil typespec)))))
     711    (specifier-type typespec env)))
     712
    687713(defun nx-check-vdecl-var-ref (decl)
    688714  (unless (eq (cadr decl) 'special)
     
    755781      (nx-bad-decls decl))))
    756782
     783(defnxdecl notspecial (pending decl env)
     784  (declare (ignore env))
     785  (dolist (s (%cdr decl))
     786    (if (symbolp s)
     787      (nx-new-vdecl pending s 'notspecial)
     788      (nx-bad-decls decl))))
     789
     790
    757791(defnxdecl dynamic-extent (pending decl env)
    758792  (declare (ignore env))
     
    782816
    783817(defnxdecl ftype (pending decl env)
    784   (declare (ignore env))
    785818  (destructuring-bind (type &rest fnames) (%cdr decl)
    786     (dolist (s fnames)
    787       (nx-new-fdecl pending s 'ftype type))))
     819    (if (not (every (lambda (f) (or (symbolp f) (setf-function-name-p f))) fnames))
     820      (nx-bad-decls decl)
     821      (let ((ctype (specifier-type-if-known type env :whine t)))
     822        (when ctype
     823          (dolist (s fnames)
     824            (nx-new-fdecl pending s 'ftype type)))))))
    788825
    789826(defnxdecl settable (pending decl env)
     
    800837      (nx-bad-decls decl))))
    801838
     839(defnxdecl function (pending decl env)
     840  (nx-process-type-decl pending decl (car decl) (cdr decl) env))
     841
    802842(defnxdecl type (pending decl env)
    803   (declare (ignore env))
    804   (labels ((kludge (type) ; 0 => known, 1 => unknown, 2=> illegal
    805              (cond ((type-specifier-p type)
    806                     0)
    807                    ((and (consp type)
    808                          (member (car type) '(and or))
    809                          (not (null (list-length type))))
    810                     (do ((result 0 (max result (kludge (car tail))))
    811                          (tail (cdr type) (cdr tail)))
    812                         ((null tail)
    813                          result)))
    814                    ((not (symbolp type))
    815                     ;;>>>> nx-bad-decls shouldn't signal a fatal error!!!!
    816                     ;;>>>> Most callers of nx-bad-decls should just ignore the
    817                     ;;>>>> losing decl element and proceed with the rest
    818                     ;;>>>>  (ie (declare (ignore foo (bar) baz)) should
    819                     ;;>>>>   have the effect of ignoring foo and baz as well
    820                     ;;>>>>   as WARNING about the mal-formed declaration.)
    821                     (nx-bad-decls decl)
    822                     2)
    823                    (t 1))))
    824     (let* ((spec (%cdr decl))
    825            (type (car spec)))
    826       (case (kludge type)
    827         ((0)
    828          (dolist (sym (cdr spec))
    829            (if (symbolp sym)
    830              (nx-new-vdecl pending sym 'type type)
    831              (nx-bad-decls decl))))
    832         ((1)
    833          (dolist (sym (cdr spec))
    834            (unless (symbolp sym)
    835              (nx-bad-decls decl))))
    836         ((2)
    837          (nx-bad-decls decl))))))
    838 
    839 
     843  (nx-process-type-decl pending decl (cadr decl) (cddr decl) env))
     844
     845(defun nx-process-type-decl (pending decl type vars env)
     846  (if (not (every #'symbolp vars))
     847    (nx-bad-decls decl)
     848    (let ((ctype (specifier-type-if-known type env :whine t)))
     849      (when ctype
     850        (dolist (sym vars)
     851          (nx-new-vdecl pending sym 'type ctype))))))
    840852
    841853(defnxdecl global-function-name (pending decl env)
  • trunk/source/compiler/nx1.lisp

    r12036 r12045  
    2929  ;; in type declarations, but aren't legal args to TYPEP;
    3030  ;; treat them as the simple FUNCTION type.
    31   (let* ((ctype (values-specifier-type typespec)))
    32     (if (typep ctype 'values-ctype)       
     31  (let* ((ctype (handler-case (values-specifier-type typespec)
     32                  (parse-unknown-type (c)
     33                    (when *compiler-warn-on-undefined-type-references*
     34                      (nx1-whine :undefined-type (parse-unknown-type-specifier c))
     35                      nil))
     36                  (program-error (c)
     37                    (nx1-whine :invalid-type typespec c)
     38                    nil))))
     39    (if (or (null ctype) (typep ctype 'values-ctype))
    3340      (setq typespec '*)
    3441      (if (typep ctype 'function-ctype)
  • trunk/source/compiler/optimizers.lisp

    r11977 r12045  
    641641      `(progn ,@body))))
    642642
    643 (defun specifier-type-if-known (typespec &optional env)
    644   (handler-case (specifier-type typespec env)
    645     (parse-unknown-type (c) (values nil (parse-unknown-type-specifier c)))))
    646 
    647 #+debugging-version
    648 (defun specifier-type-if-known (typespec &optional env)
    649   (handler-bind ((parse-unknown-type (lambda (c)
    650                                        (break "caught unknown-type ~s" c)
    651                                        (return-from specifier-type-if-known
    652                                          (values nil (parse-unknown-type-specifier c))))))
    653     (specifier-type typespec env)))
    654 
    655 
    656643(defun target-element-type-type-keyword (typespec &optional env)
    657   (let* ((ctype (specifier-type-if-known `(array ,typespec) env)))
    658     (if (null ctype)
    659       (progn
    660         (nx1-whine :unknown-type-declaration typespec)
    661         nil)
     644  (let ((ctype (specifier-type-if-known `(array ,typespec) env)))
     645    (when ctype
    662646      (funcall (arch::target-array-type-name-from-ctype-function
    663                 (backend-target-arch *target-backend*))
    664                ctype))))
     647                (backend-target-arch *target-backend*))
     648               ctype))))
    665649
    666650(defun infer-array-type (dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)
     
    699683                         '*)
    700684                       t))
    701            (element-type (or (specifier-type-if-known typespec env)
    702                              (make-unknown-ctype :specifier typespec))))
    703       (setf (array-ctype-element-type ctype) element-type)
    704       (if (typep element-type 'unknown-ctype)
    705         (setf (array-ctype-element-type ctype) *wild-type*))
     685           (element-type (specifier-type-if-known typespec env :whine t)))
     686      (setf (array-ctype-element-type ctype) (or element-type *wild-type*))
    706687      (specialize-array-type ctype))
    707688    (type-specifier ctype)))
     
    729710             (expansion
    730711              (cond ((and initial-element-p initial-contents-p)
    731                      (nx1-whine 'illegal-arguments call)
     712                     (signal-program-error  "Incompatible arguments :INITIAL-ELEMENT and :INITIAL-CONTENTS in ~s" call)
    732713                     call)
    733714                    (displaced-to-p
     
    958939                  (and (quoted-form-p type)
    959940                       (setq type (%cadr type))))
    960               (setq ctype (specifier-type-if-known type env)))
     941              (setq ctype (specifier-type-if-known type env :whine t)))
    961942         (cond ((nx-form-typep arg type env) arg)
    962943               ((eq type 'simple-vector)
     
    15181499
    15191500
    1520 
    15211501(defun optimize-typep (thing type env)
    15221502  ;; returns a new form, or nil if it can't optimize
    1523   (let* ((ctype (specifier-type-if-known type env)))
     1503  (let ((ctype (specifier-type-if-known type env :whine t)))
    15241504    (when ctype
    15251505      (let* ((type (type-specifier ctype))
     
    22792259
    22802260(define-compiler-macro coerce (&whole call &environment env thing type)
    2281   (cond ((constantp type)
    2282          (if (quoted-form-p type)
    2283            (setq type (cadr type)))
    2284          (if (ignore-errors (subtypep type 'single-float))
    2285            `(float ,thing 0.0f0)
    2286            (if (ignore-errors (subtypep type 'double-float))
    2287              `(float ,thing 0.0d0)
    2288              (let* ((ctype (specifier-type-if-known type env))
    2289                     (simple nil)
    2290                     (extra nil))
    2291                (if (and (typep ctype 'array-ctype)
    2292                         (equal (array-ctype-dimensions ctype) '(*)))
    2293                  (if (eq (array-ctype-specialized-element-type ctype)
    2294                          (specifier-type 'character))
    2295                    (setq simple '%coerce-to-string)
    2296                    (if (and (eq *host-backend* *target-backend*)
    2297                             (array-ctype-typecode ctype))
    2298                      (setq simple '%coerce-to-vector
    2299                            extra (list (array-ctype-typecode ctype)))))
    2300                  (if (eq ctype (specifier-type 'list))
    2301                    (setq simple '%coerce-to-list)))
    2302                (if simple
    2303                  (let* ((temp (gensym)))
    2304                    `(let* ((,temp ,thing))
    2305                      (if (typep ,temp ',(type-specifier ctype))
    2306                        ,temp
    2307                        (,simple ,temp ,@extra))))
    2308                call)))))
     2261  (cond ((quoted-form-p type)
     2262         (setq type (cadr type))
     2263         (let ((ctype (specifier-type-if-known type env :whine t)))
     2264           (if ctype
     2265             (if (csubtypep ctype (specifier-type 'single-float))
     2266                 `(float ,thing 0.0f0)
     2267                 (if (csubtypep ctype (specifier-type 'double-float))
     2268                     `(float ,thing 0.0d0)
     2269                     (let ((simple nil)
     2270                           (extra nil))
     2271                       (if (and (typep ctype 'array-ctype)
     2272                                (equal (array-ctype-dimensions ctype) '(*)))
     2273                           (if (eq (array-ctype-specialized-element-type ctype)
     2274                                   (specifier-type 'character))
     2275                               (setq simple '%coerce-to-string)
     2276                               (if (and (eq *host-backend* *target-backend*)
     2277                                        (array-ctype-typecode ctype))
     2278                                   (setq simple '%coerce-to-vector
     2279                                         extra (list (array-ctype-typecode ctype)))))
     2280                           (if (eq ctype (specifier-type 'list))
     2281                               (setq simple '%coerce-to-list)))
     2282                       (if simple
     2283                           (let* ((temp (gensym)))
     2284                             `(let* ((,temp ,thing))
     2285                                (if (typep ,temp ',(type-specifier ctype))
     2286                                    ,temp
     2287                                    (,simple ,temp ,@extra))))
     2288                           call))))
     2289             call)))
    23092290        (t call)))
    23102291
  • trunk/source/level-1/l1-clos-boot.lisp

    r11855 r12045  
    556556
    557557
    558 (defstatic *type-system-initialized* nil)
    559 
    560558(eval-when (eval compile)
    561559  (require 'defstruct-macros))
     
    13561354
    13571355(defun %compile-time-defclass (name environment)
     1356  (note-type-info name 'class environment)
    13581357  (unless (find-class name nil environment)
    13591358    (let ((defenv (definition-environment environment)))
  • trunk/source/level-1/l1-clos.lisp

    r11999 r12045  
    12011201
    12021202;;; Fake method-combination, redefined in lib;method-combination.
    1203 (defclass method-combination (metaobject)
    1204   ((name :initarg :name)))
     1203(unless *type-system-initialized*
     1204 (defclass method-combination (metaobject)
     1205   ((name :initarg :name))))
    12051206
    12061207
  • trunk/source/level-1/l1-error-system.lisp

    r11932 r12045  
    7575  ((warning-type :initform :unsure)
    7676   (args :initform nil)))
    77 (define-condition undefined-function-reference (style-warning) ())
     77(define-condition undefined-reference (style-warning) ())
     78(define-condition undefined-type-reference (undefined-reference) ())
     79(define-condition undefined-function-reference (undefined-reference) ())
    7880(define-condition macro-used-before-definition (compiler-warning) ())
     81(define-condition invalid-type-warning (style-warning) ())
    7982(define-condition invalid-arguments (style-warning) ())
    8083(define-condition invalid-arguments-global (style-warning) ())
  • trunk/source/level-1/l1-init.lisp

    r11373 r12045  
    165165  "symbols which are magical in a lambda list")
    166166
     167(defstatic *type-system-initialized* nil)
    167168
    168169(defparameter %toplevel-catch% ':toplevel)
     
    239240(defvar ccl::*kernel-restarts* nil)
    240241(defvar *condition-restarts* nil "explicit mapping between c & r")
    241 (declaim (type list %handlers% %restarts% ccl::*kernel-restarts* *condition-restarts*))
     242(declaim (list %handlers% %restarts% ccl::*kernel-restarts* *condition-restarts*))
    242243
    243244
  • trunk/source/level-1/l1-readloop.lisp

    r11901 r12045  
    410410    (defmacro (setq lambda '(macro) lfbits nil)) ;; some code assumes lfbits=nil
    411411    (defgeneric (setq lambda (list :methods)))
    412     (defmethod (setq lambda (list :methods (cons qualifiers specializers)))))
     412    (defmethod (setq lambda (list :methods (cons qualifiers specializers))))
     413    (deftype (setq lambda '(type) lfbits (cons nil *loading-file-source-file*))))
    413414  (vector lfbits keyvect *loading-file-source-file* lambda))
    414415
    415416(defun def-info.lfbits (def-info)
    416   (and def-info (svref def-info 0)))
     417  (and def-info
     418       (let ((lfbits (svref def-info 0)))
     419         (if (consp lfbits) (%car lfbits) lfbits))))
    417420
    418421(defun def-info.keyvect (def-info)
     
    423426
    424427(defun def-info.lambda (def-info)
    425   (let ((data (and def-info (svref def-info 3))))
    426     (and (eq (car data) 'lambda) data)))
     428  (and def-info
     429       (let ((data (svref def-info 3)))
     430         (and (eq (car data) 'lambda) data))))
    427431
    428432(defun def-info.methods (def-info)
    429   (let ((data (and def-info (svref def-info 3))))
    430     (and (eq (car data) :methods) (%cdr data))))
     433  (and def-info
     434       (let ((data (svref def-info 3)))
     435         (and (eq (car data) :methods) (%cdr data)))))
    431436
    432437(defun def-info-with-new-methods (def-info new-methods)
    433   (unless (eq (def-info.type def-info) 'defgeneric) (error "Bug: not method info: ~s" def-info))
    434438  (if (eq new-methods (def-info.methods def-info))
    435439    def-info
     
    442446    (eq (car data) 'macro)))
    443447
    444 (defun def-info.type (def-info)
    445   (if (null def-info) nil  ;; means FTYPE decl or lap function
     448(defun def-info.function-p (def-info)
     449  (not (and def-info (eq (car (svref def-info 3)) 'type))))
     450
     451(defun def-info.function-type (def-info)
     452  (if (null def-info)
     453    nil ;; ftype only, for the purposes here, is same as nothing.
    446454    (let ((data (svref def-info 3)))
    447455      (ecase (car data)
    448         ((nil lambda) 'defun)
    449         (:methods 'defgeneric)
    450         (macro 'defmacro)))))
     456        ((nil lambda) 'defun)
     457        (:methods 'defgeneric)
     458        (macro 'defmacro)
     459        (ftype nil)
     460        (type nil)))))
     461
     462(defun def-info.deftype (def-info)
     463  (and def-info
     464       (let ((bits (svref def-info 0)))
     465         ;; bits or (bits . type-source-file)
     466         (and (consp bits) bits))))
     467
     468(defun def-info.deftype-type (def-info)
     469  ;; 'class (for defclass/defstruct) or 'macro (for deftype et. al.)
     470  (and def-info
     471       (consp (svref def-info 0))
     472       (svref def-info 1)))
    451473
    452474(defparameter *one-arg-defun-def-info* (%cons-def-info 'defun (encode-lambda-list '(x))))
     
    454476(defvar *compiler-warn-on-duplicate-definitions* t)
    455477
    456 (defun combine-function-infos (name old-info new-info)
    457   (let ((old-type (def-info.type old-info))
    458         (new-type (def-info.type new-info)))
     478(defun combine-deftype-infos (name def-info old-deftype new-deftype)
     479  (when (or new-deftype old-deftype)
     480    (when (and old-deftype new-deftype *compiler-warn-on-duplicate-definitions*)
     481      (nx1-whine :duplicate-definition
     482                 `(type ,name)
     483                 (cdr old-deftype)
     484                 (cdr new-deftype)))
     485    (let ((target (if new-deftype
     486                      (or (cdr new-deftype) (cdr old-deftype))
     487                      (cdr old-deftype)))
     488          (target-deftype (def-info.deftype def-info)))
     489      (unless (and target-deftype (eq (cdr target-deftype) target))
     490        (setq def-info (copy-seq (or def-info '#(nil nil nil (ftype)))))
     491        (setf (svref def-info 0) (cons (def-info.lfbits def-info) target)))))
     492  def-info)
     493
     494#+debug
     495(defun describe-def-info (def-info)
     496  (list :lfbits (def-info.lfbits def-info)
     497        :keyvect (def-info.keyvect def-info)
     498        :macro-p (def-info.macro-p def-info)
     499        :function-p (def-info.function-p def-info)
     500        :lambda (and (def-info.function-p def-info) (def-info.lambda def-info))
     501        :methods (and (def-info.function-p def-info) (def-info.methods def-info))
     502        :function-type (def-info.function-type def-info)
     503        :deftype (def-info.deftype def-info)
     504        :deftype-type (def-info.deftype-type def-info)))
     505
     506(defun combine-definition-infos (name old-info new-info)
     507  (let ((old-type (def-info.function-type old-info))  ;; defmacro
     508        (old-deftype (def-info.deftype old-info))      ;; nil
     509        (new-type (def-info.function-type new-info))  ;; nil
     510        (new-deftype (def-info.deftype new-info)))   ;; (nil . file)
    459511    (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric))
    460512           ;; TODO: Check compatibility of lfbits...
     
    470522                                     (def-info.file new-info)))
    471523                        (push new-method old-methods)))
    472              (def-info-with-new-methods old-info old-methods)))
    473           ((or (eq (or old-type 'defun) (or new-type 'defun))
    474                (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))
     524             (setq new-info (def-info-with-new-methods old-info old-methods))))
     525          ((or (eq (or old-type 'defun) (or new-type 'defun))
     526               (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))
    475527           (when (and old-type new-type *compiler-warn-on-duplicate-definitions*)
    476528             (nx1-whine :duplicate-definition name (def-info.file old-info) (def-info.file new-info)))
    477            (or new-info old-info))
     529           (unless new-info (setq new-info old-info)))
    478530          (t
    479            (when *compiler-warn-on-duplicate-definitions*
     531           (when (and (def-info.function-p old-info) (def-info.function-p new-info)
     532                      *compiler-warn-on-duplicate-definitions*)
    480533             (apply #'nx1-whine :duplicate-definition
    481534                    name
     
    486539                          ((eq old-type 'defgeneric) '("generic function" "function"))
    487540                          (t '("function" "generic function")))))
    488            new-info))))
    489 
    490 (defun record-function-info (name info env)
     541           (unless new-type (setq new-info old-info))))
     542    (combine-deftype-infos name new-info old-deftype new-deftype)))
     543
     544(defun record-definition-info (name info env)
    491545  (let* ((definition-env (definition-environment env)))
    492546    (if definition-env
     
    494548             (already (if (listp defs) (assq name defs) (gethash name defs))))
    495549        (if already
    496           (setf (%cdr already) (combine-function-infos name (%cdr already) info))
     550          (setf (%cdr already) (combine-definition-infos name (%cdr already) info))
    497551          (let ((outer (loop for defer = (cdr (defenv.type definition-env))
    498552                               then (deferred-warnings.parent defer)
     
    500554                             thereis (gethash name (deferred-warnings.defs defer)))))
    501555            (when outer
    502               (setq info (combine-function-infos name (%cdr outer) info)))
     556              (setq info (combine-definition-infos name (%cdr outer) info)))
    503557            (let ((new (cons name info)))
    504558              (if (listp defs)
     
    507561        info))))
    508562
     563(defun record-function-info (name info env)
     564  (record-definition-info name info env))
    509565
    510566;;; This is different from AUGMENT-ENVIRONMENT.
     
    519575  name)
    520576
     577(defun note-type-info (name kind env)
     578  (record-definition-info name (%cons-def-info 'deftype nil kind) env))
     579
     580
    521581; And this is different from FUNCTION-INFORMATION.
    522582(defun retrieve-environment-function-info (name env)
    523583 (let ((defenv (definition-environment env)))
    524584   (when defenv
    525      (let ((defs (defenv.defined defenv))
    526            (sym (maybe-setf-function-name name)))
    527        (if (listp defs) (assq sym defs) (gethash sym defs))))))
     585     (let* ((defs (defenv.defined defenv))
     586            (sym (maybe-setf-function-name name))
     587            (info (if (listp defs) (assq sym defs) (gethash sym defs))))
     588       (and info (def-info.function-p (cdr info)) info)))))
    528589
    529590(defun maybe-setf-function-name (name)
  • trunk/source/level-1/l1-typesys.lisp

    r12026 r12045  
    114114                  (let ((c (find-class name nil)))
    115115                    (and c (eq (class-name c) name)))))
    116          (error "Cannot redefine type ~S" name))
     116         (error "Cannot redefine type ~S because ~:[it is the name of a class~;it is a built-in type~]" name (built-in-type-p name)))
     117        ((memq name *nx-known-declarations*)
     118         (check-declaration-redefinition name 'deftype))
    117119        (t (setf (gethash name %deftype-expanders%) fn)
    118120           (record-source-file name 'type)))
     
    146148  (multiple-value-bind (lambda doc)
    147149      (parse-macro-internal name arglist body env '*)
    148       `(eval-when (:compile-toplevel :load-toplevel :execute)
    149          (,definer ',name
    150                    (nfunction ,name ,lambda)
    151                    ,doc))))
     150    `(progn
     151       (eval-when (:compile-toplevel)
     152         (note-type-info ',name 'macro ,env))
     153       (eval-when (:compile-toplevel :load-toplevel :execute)
     154         (,definer ',name
     155             (nfunction ,name ,lambda)
     156           ,doc)))))
    152157
    153158(defmacro deftype (name arglist &body body &environment env)
     
    904909;;;
    905910(defun values-type-types (type &optional (default-type *empty-type*))
    906   (declare (type values-type type))
     911  (declare (type values-ctype type))
    907912  (values (append (args-ctype-required type)
    908913                  (args-ctype-optional type))
     
    15411546  (handler-case
    15421547      (type-specifier (specifier-type spec env))
    1543     (invalid-type-specifier () spec)
     1548    (program-error () spec)
    15441549    (parse-unknown-type () spec)))
    15451550
     
    24702475  (coerce-bound bound type #'coerce))
    24712476
     2477#|
    24722478(def-type-translator real (&optional (low '*) (high '*))
    24732479  (specifier-type `(or (float ,(coerced-real-bound  low 'float)
     
    24822488        (double-float ,(coerced-float-bound  low 'double-float)
    24832489                      ,(coerced-float-bound high 'double-float)))))
     2490|#
    24842491
    24852492(def-bounded-type float float nil)
     
    25872594;;;
    25882595(define-type-method (number :simple-intersection) (type1 type2)
    2589   (declare (type numeric-type type1 type2))
     2596  (declare (type numeric-ctype type1 type2))
    25902597  (if (numeric-types-intersect type1 type2)
    25912598    (let* ((class1 (numeric-ctype-class type1))
     
    33633370           
    33643371(define-type-method (cons :simple-intersection) (type1 type2)
    3365   (declare (type cons-type type1 type2))
     3372  (declare (type cons-ctype type1 type2))
    33663373  (let ((car-int2 (type-intersection2 (cons-ctype-car-ctype type1)
    33673374                                      (cons-ctype-car-ctype type2)))
     
    43424349                    (unless (eq ctype *universal-type*)
    43434350                      (generate-predicate-for-ctype ctype)))
    4344                 (invalid-type-specifier ()
    4345                   (warn "Invalid type soecifier ~s in slot definition for ~s in class ~s." type (slot-definition-name spec) (slot-definition-class spec))
     4351                (program-error ()
     4352                  (warn "Invalid type specifier ~s in slot definition for ~s in class ~s." type (slot-definition-name spec) (slot-definition-class spec))
    43464353                  (lambda (v)
    43474354                    (cerror "Allow the assignment or initialization."
  • trunk/source/level-1/l1-utils.lisp

    r11373 r12045  
    537537    ;(function (proclaim-ftype (cons 'function (cddr spec)) (cadr spec)))
    538538    (t (unless (memq (%car spec) *nx-known-declarations*) ;not really right...
    539          ;; Any type name is now (ANSI CL) a valid declaration.
    540          (if (and (symbolp (%car spec))
    541                   (type-specifier-p (%car spec)))
     539         ;; Any type name is now (ANSI CL) a valid declaration.  Any symbol could become a type.
     540         (if (symbolp (%car spec))
    542541           (apply #'proclaim-type spec)
    543542           (warn "Unknown declaration specifier(s) in ~S" spec))))))
     
    548547    (if (symbolp var)
    549548      (let ((spec (assq var *nx-proclaimed-types*)))
     549        ;; Check the type.  This will signal program-error's in case of invalid types, let it.
     550        (when *type-system-initialized*
     551          (handler-case (specifier-type type)
     552            (parse-unknown-type (c)
     553              (warn "Undefined type ~s declaration for ~S" (parse-unknown-type-specifier c) var))))
    550554        (if spec
    551555          (rplacd spec type)
     
    594598  (declare (dynamic-extent syms))
    595599  (dolist (sym syms)
     600    (when (type-specifier-p sym)
     601      (error "Cannot define declaration ~s because it is the name of a type" sym))
    596602    (setq *nx-known-declarations*
    597603          (adjoin sym *nx-known-declarations* :test 'eq))))
     604
     605(defun check-declaration-redefinition (name why)
     606  (when (memq name *nx-known-declarations*)
     607    (cerror "Undeclare the declaration ~*~s"
     608            "Cannot ~a ~s because ~:*~s has been declared as a declaration name" why name)
     609    (setq *nx-known-declarations* (remove name *nx-known-declarations*))))
    598610
    599611(defun proclaim-ignore (t-or-nil &rest syms)
  • trunk/source/level-1/sysutils.lisp

    r11600 r12045  
    555555
    556556
     557;; Should be a generic function but compiler-warning class not defined yet.
     558(defun verify-deferred-warning (w)
     559  (etypecase w
     560    (undefined-type-reference (verify-deferred-type-warning w))
     561    (undefined-function-reference (verify-deferred-function-warning w))
     562    (compiler-warning nil)))
     563
     564(defun verify-deferred-type-warning (w)
     565  (let* ((args (compiler-warning-args w))
     566         (typespec (car args))
     567         (defs (deferred-warnings.defs *outstanding-deferred-warnings*)))
     568    (handler-bind ((parse-unknown-type
     569                    (lambda (c)
     570                      (let* ((type (parse-unknown-type-specifier c))
     571                             (spec (if (consp type) (car type) type))
     572                             (cell (and (symbolp spec) (gethash spec defs))))
     573                        (unless (and cell (def-info.deftype (cdr cell)))
     574                          (when (and args (neq type typespec))
     575                            (setf (car args) type))
     576                          (return-from verify-deferred-type-warning w))
     577                        ;; Else got defined.  TODO: Should check syntax, but don't have enuff info.
     578                        ;; TODO: should note if got defined as a deftype (rather than class or struct) and
     579                        ;; warn about forward reference, akin to the macro warning?  Might be missing out on
     580                        ;; some intended optimizations.
     581                        )))
     582                   (program-error ;; got defined, but turns out it's being used wrong
     583                    (lambda (c)
     584                      (let ((w2 (make-condition 'invalid-type-warning
     585                                  :file-name (compiler-warning-file-name w)
     586                                  :function-name (compiler-warning-function-name w)
     587                                  :source-note (compiler-warning-source-note w)
     588                                  :warning-type :invalid-type
     589                                  :args (list typespec c))))
     590                        (setf (compiler-warning-stream-position w2)
     591                              (compiler-warning-stream-position w))
     592                        (return-from verify-deferred-type-warning w2)))))
     593      (values-specifier-type typespec)
     594      nil)))
     595
     596
     597(defun verify-deferred-function-warning (w)
     598  (let* ((args (compiler-warning-args w))
     599         (wfname (car args))
     600         (defs (deferred-warnings.defs *outstanding-deferred-warnings*))
     601         (def (or (let ((cell (gethash wfname defs)))
     602                   (and cell (def-info.function-p (cdr cell)) cell))
     603                 (let* ((global (fboundp wfname)))
     604                   (and (typep global 'function) global)))))
     605    (cond ((null def) w)
     606          ((or (typep def 'function)
     607               (and (consp def)
     608                    (def-info.lfbits (cdr def))))
     609           ;; Check args in call to forward-referenced function.
     610           (when (cdr args)
     611             (destructuring-bind (arglist spread-p) (cdr args)
     612               (multiple-value-bind (deftype reason)
     613                   (nx1-check-call-args def arglist spread-p)
     614                 (when deftype
     615                   (let* ((w2 (make-condition
     616                               'invalid-arguments
     617                               :file-name (compiler-warning-file-name w)
     618                               :function-name (compiler-warning-function-name w)
     619                               :source-note (compiler-warning-source-note w)
     620                               :warning-type deftype
     621                               :args (list (car args) reason arglist spread-p))))
     622                     (setf (compiler-warning-stream-position w2)
     623                           (compiler-warning-stream-position w))
     624                     w2))))))
     625          ((def-info.macro-p (cdr def))
     626           (let* ((w2 (make-condition
     627                       'macro-used-before-definition
     628                       :file-name (compiler-warning-file-name w)
     629                       :function-name (compiler-warning-function-name w)
     630                       :source-note (compiler-warning-source-note w)
     631                       :warning-type :macro-used-before-definition
     632                       :args (list (car args)))))
     633             (setf (compiler-warning-stream-position w2)
     634                   (compiler-warning-stream-position w))
     635             w2)))))
     636
     637
    557638(defun report-deferred-warnings (&optional (file nil))
    558639  (let* ((current (ensure-merged-deferred-warnings *outstanding-deferred-warnings*))
    559640         (parent (deferred-warnings.parent current))
    560641         (warnings (deferred-warnings.warnings current))
    561          (defs (deferred-warnings.defs current))
    562642         (any nil)
    563643         (harsh nil))
     
    570650      (let* ((file nil)
    571651             (init t))
    572         (flet ((signal-warning (w)
    573                  (multiple-value-setq (harsh any file) (signal-compiler-warning w init file harsh any))
    574                  (setq init nil)))
    575           (dolist (w warnings)
    576             (let* ((args (compiler-warning-args w))
    577                    (wfname (car args))
    578                    (def nil))
    579               (when (if (typep w 'undefined-function-reference)
    580                       (not (setq def (or (gethash wfname defs)
    581                                          (let* ((global (fboundp wfname)))
    582                                            (if (typep global 'function)
    583                                              global))))))
    584                 (signal-warning w))
    585               ;; Check args in call to forward-referenced function.
    586               (if (or (typep def 'function)
    587                       (and (consp def)
    588                            (def-info.lfbits (cdr def))))
    589                 (when (cdr args)
    590                   (destructuring-bind (arglist spread-p)
    591                       (cdr args)
    592                     (multiple-value-bind (deftype reason)
    593                         (nx1-check-call-args def arglist spread-p)
    594                       (when deftype
    595                         (let* ((w2 (make-condition
    596                                     'invalid-arguments
    597                                     :file-name (compiler-warning-file-name w)
    598                                     :function-name (compiler-warning-function-name w)
    599                                     :warning-type deftype
    600                                     :args (list (car args) reason arglist spread-p))))
    601                           (setf (compiler-warning-stream-position w2)
    602                                 (compiler-warning-stream-position w))
    603                           (signal-warning w2))))))
    604                 (if (def-info.macro-p (cdr def))
    605                   (let* ((w2 (make-condition
    606                               'macro-used-before-definition
    607                               :file-name (compiler-warning-file-name w)
    608                               :function-name (compiler-warning-function-name w)
    609                               :warning-type :macro-used-before-definition
    610                               :args (list (car args)))))
    611                     (setf (compiler-warning-stream-position w2)
    612                           (compiler-warning-stream-position w))
    613                     (signal-warning w2)))))))))
     652        (dolist (w warnings)
     653          (when (setq w (verify-deferred-warning w))
     654            (multiple-value-setq (harsh any file) (signal-compiler-warning w init file harsh any))
     655            (setq init nil)))))
    614656    (values any harsh parent)))
    615657
  • trunk/source/lib/defstruct-lds.lisp

    r10942 r12045  
    243243    (return
    244244     `(progn
     245        ,@(when (null (sd-type sd))
     246                `((when (memq ',struct-name *nx-known-declarations*)
     247                    (check-declaration-redefinition ',struct-name 'defstruct))))
    245248       (remove-structure-defs  ',struct-name) ; lose any previous defs
    246249        ,.(defstruct-slot-defs sd refnames env)
  • trunk/source/lib/encapsulate.lisp

    r11679 r12045  
    681681               &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
    682682       (declare (dynamic-extent args))
     683       (declare (ftype function ,def))
    683684       (let ((*trace-level* (1+ *trace-level*))
    684685             (,enable ,if))
  • trunk/source/lib/macros.lisp

    r11855 r12045  
    19911991                        (setq type-p t))
    19921992                      (setq type (cadr options))
    1993                       ;; complain about illegal typespecs
     1993                      ;; complain about illegal typespecs and continue
    19941994                      (handler-case (specifier-type type env)
    1995                         (invalid-type-specifier ()
     1995                        (program-error ()
    19961996                          (warn "Invalid type ~s in ~s slot definition ~s" type class-name slot))))
    19971997                     (:initform
     
    20452045                                      (length illegal) illegal keyvect))))
    20462046          `(progn
     2047             (when (memq ',class-name *nx-known-declarations*)
     2048               (check-declaration-redefinition ',class-name 'defclass))
    20472049            (eval-when (:compile-toplevel)
    20482050              (%compile-time-defclass ',class-name ,env)
  • trunk/source/lib/nfcomp.lisp

    r12037 r12045  
    764764
    765765
    766 (defun fcomp-proclaim-type (type syms)
     766(defun fcomp-proclaim-type (type syms env)
    767767  (dolist (sym syms)
    768768    (if (symbolp sym)
    769       (push (cons sym type) *nx-compile-time-types*)
    770       (warn "~S isn't a symbol in ~S type declaration while compiling ~S."
    771             sym type *fasl-source-file*))))
     769      (progn
     770        (specifier-type-if-known type env :whine t)
     771        (push (cons sym type) *nx-compile-time-types*))
     772      (nx-bad-decls `(type ,type ,sym)))))
    772773
    773774(defun compile-time-proclamation (specs env &aux  sym (defenv (definition-environment env)))
     
    777778      (case sym
    778779        (type
    779          (fcomp-proclaim-type (car spec) (cdr spec)))
     780         (fcomp-proclaim-type (car spec) (cdr spec) env))
    780781        (special
    781782         (dolist (sym spec)
     
    816817             (push (list* (maybe-setf-function-name fname) sym ftype) (lexenv.fdecls defenv)))))
    817818        (otherwise
    818          (if (memq (if (consp sym) (%car sym) sym) *cl-types*)
    819            (fcomp-proclaim-type sym spec)       ; A post-cltl2 cleanup issue changes this
    820            nil)                         ; ---- probably ought to complain
    821          )))))
     819         (unless (memq sym *nx-known-declarations*)
     820           ;; Any type name is now (ANSI CL) a valid declaration.
     821           (if (symbolp sym)
     822             (fcomp-proclaim-type sym spec env)
     823             (nx-bad-decls `(,sym ,spec)))))))))
    822824
    823825(defun fcomp-load-%defun (form env)
     
    846848    (fcomp-random-toplevel-form form env)))
    847849
     850#-BOOTSTRAPPED (unless (fboundp 'note-type-info)
     851                 (fset 'note-type-info (nlambda bootstrapping-note-type-info (name kind env) (declare (ignore name kind env)))))
     852
     853
    848854(defun define-compile-time-structure (sd refnames predicate env)
    849855  (let ((defenv (definition-environment env)))
    850856    (when defenv
    851857      (when (non-nil-symbolp (sd-name sd))
     858        (note-type-info (sd-name sd) 'class env)
    852859        (push (make-instance 'compile-time-class :name (sd-name sd))
    853860              (defenv.classes defenv)))
     
    10011008      lfun)))
    10021009
    1003 ; For now, defer only UNDEFINED-FUNCTION-REFERENCEs, signal all others via WARN.
     1010; For now, defer only UNDEFINED-REFERENCEs, signal all others via WARN.
    10041011; Well, maybe not WARN, exactly.
    10051012(defun fcomp-signal-or-defer-warnings (warnings env)
     
    10101017      (setf (compiler-warning-file-name w) *fasl-source-file*)
    10111018      (setf (compiler-warning-stream-position w) *fcomp-stream-position*)
    1012       (if (and (typep w 'undefined-function-reference)
     1019      (if (and (typep w 'undefined-reference)
    10131020               (eq w (setq w (macro-too-late-p w env))))
    10141021        (push w *fasl-deferred-warnings*)
     
    10261033  (let* ((args (compiler-warning-args w))
    10271034         (name (car args)))
    1028     (if (or (macro-function name)
    1029             (let* ((defenv (definition-environment env))
    1030                    (info (if defenv (assq name (defenv.functions defenv)))))
    1031               (and (consp (cdr info))
    1032                    (eq 'macro (cadr info)))))
    1033       (make-instance 'macro-used-before-definition
    1034         :file-name (compiler-warning-file-name w)
    1035         :function-name (compiler-warning-function-name w)
    1036         :warning-type ':macro-used-before-definition
    1037         :args args)
     1035    (if (typep w 'undefined-function-reference)
     1036      (if (or (macro-function name)
     1037              (let* ((defenv (definition-environment env))
     1038                     (info (if defenv (assq name (defenv.functions defenv)))))
     1039                (and (consp (cdr info))
     1040                     (eq 'macro (cadr info)))))
     1041          (make-instance 'macro-used-before-definition
     1042            :file-name (compiler-warning-file-name w)
     1043            :function-name (compiler-warning-function-name w)
     1044            :warning-type ':macro-used-before-definition
     1045            :args args)
     1046          w)
    10381047      w)))
    10391048
Note: See TracChangeset for help on using the changeset viewer.