Changeset 12045 for trunk/source/level-1


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/level-1
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • 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
Note: See TracChangeset for help on using the changeset viewer.