Changeset 12585


Ignore:
Timestamp:
Aug 15, 2009, 2:40:54 PM (10 years ago)
Author:
gz
Message:

more extensive compile-time checking involving methods/gfs: warn about incongruent lambda lists, duplicate gf defs, required keyword args (from defgeneric), and invalid keyword args in gf calls. Also fix to keep method source files in env function info so dup method warnings can cite the right file. Also merged r12581 and r12583 from trunk

Location:
branches/working-0711/ccl
Files:
9 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/nx-basic.lisp

    r12531 r12585  
    587587    (setq env (lexenv.parent-env env))))
    588588
    589 (defun report-compile-time-argument-mismatch (condition stream)
     589(defun report-compile-time-argument-mismatch (condition stream &aux (type (compiler-warning-warning-type condition)))
    590590  (destructuring-bind (callee reason args spread-p)
    591591      (compiler-warning-args condition)
     
    594594            callee
    595595            args)
    596     (case (car reason)
     596    (ecase (car reason)
    597597      (:toomany
    598598       (destructuring-bind (provided max)
     
    609609       (destructuring-bind (badguy goodguys)
    610610           (cdr reason)
    611          (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~s, which are recognized~&  by "
    612                  (consp badguy) badguy goodguys))))
     611         (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~:s, which are recognized by "
     612                 (consp badguy) badguy goodguys)))
     613      (:unknown-gf-keywords
     614         (let ((badguys (cadr reason)))
     615           (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not recognized by "
     616                   (consp badguys) badguys))))
    613617    (format stream
    614             (ecase (compiler-warning-warning-type condition)       
     618            (ecase type
    615619              (:ftype-mismatch "the FTYPE declaration of ~s")
    616620              (:global-mismatch "the current global definition of ~s")
     
    623627    (:unused . "Unused lexical variable ~S")
    624628    (:ignore . "Variable ~S not ignored.")
    625     (:undefined-function . "Undefined function ~S") ;; (not reported if defined later)
    626     (:undefined-type . "Undefined type ~S")         ;; (not reported if defined later)
     629    (:undefined-function . "Undefined function ~S") ;; (deferred)
     630    (:undefined-type . "Undefined type ~S")         ;; (deferred)
    627631    (:unknown-type-in-declaration . "Unknown or invalid type ~S, declaration ignored")
    628632    (:bad-declaration . "Unknown or invalid declaration ~S")
     
    640644    (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined.")
    641645    (:lambda . "Suspicious lambda-list: ~s")
     646    (:incongruent-gf-lambda-list . "Lambda list of generic function ~s is incongruent with previously defined methods")
     647    (:incongruent-method-lambda-list . "Lambda list of ~s is incongruent with previous definition of ~s")
     648    (:gf-keys-not-accepted . "~s does not accept keywords ~s required by the generic functions")
    642649    (:result-ignored . "Function result ignored in call to ~s")
    643650    (:duplicate-definition . report-compile-time-duplicate-definition)
  • branches/working-0711/ccl/compiler/nx.lisp

    r12515 r12585  
    199199  '((:undefined-function . undefined-function-reference)
    200200    (:undefined-type . undefined-type-reference)
     201    (:deferred-mismatch . undefined-keyword-reference)
    201202    (:invalid-type . invalid-type-warning)
    202203    (:global-mismatch . invalid-arguments-global)
  • branches/working-0711/ccl/compiler/nx0.lisp

    r12531 r12585  
    18691869
    18701870(defun nx1-type-intersect (form type1 type2 &optional (env *nx-lexical-environment*))
    1871   (let* ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1 env)))
    1872          (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2 env)))
    1873          (intersection (type-intersection ctype1 ctype2)))
     1871  (let* ((ctype1 (if (typep type1 'ctype) type1 (values-specifier-type type1 env)))
     1872         (ctype2 (if (typep type2 'ctype) type2 (values-specifier-type type2 env)))
     1873         (intersection (if (or (values-ctype-p ctype1) (values-ctype-p ctype2))
     1874                         (values-type-intersection ctype1 ctype2)
     1875                         (type-intersection ctype1 ctype2))))
    18741876    (when (eq intersection *empty-type*)
    18751877      (let ((type1 (if (typep type1 'ctype)
     
    20752077
    20762078(defun innermost-lfun-bits-keyvect (def)
    2077   (declare (notinline innermost-lfun-bits-keyvect))
    20782079  (let* ((inner-def (closure-function (find-unencapsulated-definition def)))
    20792080         (bits (lfun-bits inner-def))
    20802081         (keys (lfun-keyvect inner-def)))
    20812082    (declare (fixnum bits))
     2083    #+no
    20822084    (when (and (eq (ash 1 $lfbits-gfn-bit)
    20832085                   (logand bits (logior (ash 1 $lfbits-gfn-bit)
     
    20882090    (values bits keys)))
    20892091
     2092(defun def-info-bits-keyvect (info)
     2093  (let ((bits (def-info.lfbits info)))
     2094    (when (and (eq (def-info.function-type info) 'defgeneric)
     2095               (logbitp $lfbits-keys-bit bits)
     2096               (not (logbitp $lfbits-aok-bit bits))
     2097               (loop for m in (def-info.methods info)
     2098                     thereis (nth-value 1 (def-info-method.keyvect m))))
     2099      ;; Some method has &aok, don't bother checking keywords.
     2100      (setq bits (logior bits (ash 1 $lfbits-aok-bit))))
     2101    (values bits (def-info.keyvect info))))
     2102
    20902103
    20912104(defun nx1-check-call-args (def arglist spread-p)
    2092   (let* ((deftype (if (functionp def)
    2093                     :global-mismatch
    2094                     (if (istruct-typep def 'afunc)
    2095                       :lexical-mismatch
    2096                       :environment-mismatch)))
    2097          (reason nil))
    2098     (multiple-value-bind (bits keyvect)
    2099                          (case deftype
    2100                            (:global-mismatch (innermost-lfun-bits-keyvect def))
    2101                            (:environment-mismatch
    2102                               (values (def-info.lfbits (cdr def)) (def-info.keyvect (cdr def))))
    2103                            (t (let* ((lambda-form (afunc-lambdaform def)))
    2104                                 (if (lambda-expression-p lambda-form)
    2105                                   (encode-lambda-list (cadr lambda-form))))))
    2106       (setq reason (nx1-check-call-bits bits keyvect arglist spread-p))
    2107       (when reason
    2108         (values deftype reason)))))
    2109 
    2110 (defun nx1-check-call-bits (bits keyvect arglist spread-p)
    2111   (when bits
    2112     (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
    2113     (let* ((env *nx-lexical-environment*)
    2114            (nargs (length arglist))
    2115            (minargs (if spread-p (1- nargs) nargs))
    2116            (required (ldb $lfbits-numreq bits))
    2117            (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
    2118                   nil
    2119                   (+ required (ldb $lfbits-numopt bits)))))
    2120       ;; If the (apparent) number of args in the call doesn't
    2121       ;; match the definition, complain.  If "spread-p" is true,
    2122       ;; we can only be sure of the case when more than the
    2123       ;; required number of args have been supplied.
    2124       (or (and (not spread-p)
    2125                (< minargs required)
    2126                `(:toofew ,minargs ,required))
    2127           (and max
    2128                (> minargs max)
    2129                (list :toomany nargs max))
    2130           (nx1-find-bogus-keywords arglist spread-p bits keyvect env)))))
    2131 
    2132 (defun nx1-find-bogus-keywords (args spread-p bits keyvect env)
    2133   (declare (fixnum bits))
    2134   (when (logbitp $lfbits-aok-bit bits)
    2135     (setq keyvect nil))                 ; only check for even length tail
    2136   (when (and (logbitp $lfbits-keys-bit bits)
    2137              (not spread-p))     ; Can't be sure, last argform may contain :allow-other-keys
    2138     (do* ((bad-keys nil)
    2139           (key-values (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args))
    2140           (key-args key-values  (cddr key-args)))
    2141          ((null key-args)
    2142           (when (and keyvect bad-keys)
    2143             (list :unknown-keyword
    2144                   (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys))
    2145                   (coerce keyvect 'list))))
    2146       (unless (cdr key-args)
    2147         (return (list :odd-keywords key-values)))
    2148       (when keyvect
    2149         (let* ((keyword (%car key-args)))
    2150           (unless (nx-form-constant-p keyword env)
    2151             (return nil))
    2152           (setq keyword (nx-form-constant-value keyword env))
    2153           (if (eq keyword :allow-other-keys)
    2154             (setq keyvect nil)
    2155             (unless (position keyword keyvect)
    2156               (push keyword bad-keys))))))))
     2105  (multiple-value-bind (bits keyvect)
     2106      (etypecase def
     2107        (function (innermost-lfun-bits-keyvect def))
     2108        (afunc (let ((lambda-form (afunc-lambdaform def)))
     2109                 (and (lambda-expression-p lambda-form)
     2110                      (encode-lambda-list (cadr lambda-form) t))))
     2111        (cons (def-info-bits-keyvect (cdr def))))
     2112    (when bits
     2113      (multiple-value-bind (reason defer-p)
     2114          (or (nx1-check-call-bits bits arglist spread-p) ;; never deferred
     2115              (nx1-check-call-keywords def bits keyvect arglist spread-p))
     2116        (when reason
     2117          #-BOOTSTRAPPED (unless (find-class 'undefined-keyword-reference nil)
     2118                           (return-from nx1-check-call-args nil))
     2119          (values (if defer-p
     2120                    :deferred-mismatch
     2121                    (typecase def
     2122                      (function :global-mismatch)
     2123                      (afunc :lexical-mismatch)
     2124                      (t :environment-mismatch)))
     2125                  reason))))))
     2126
     2127(defun nx1-check-call-bits (bits arglist spread-p)
     2128  (let* ((nargs (length arglist))
     2129         (minargs (if spread-p (1- nargs) nargs))
     2130         (required (ldb $lfbits-numreq bits))
     2131         (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
     2132                nil
     2133                (+ required (ldb $lfbits-numopt bits)))))
     2134    ;; If the (apparent) number of args in the call doesn't
     2135    ;; match the definition, complain.  If "spread-p" is true,
     2136    ;; we can only be sure of the case when more than the
     2137    ;; required number of args have been supplied.
     2138    (or (and (not spread-p)
     2139             (< minargs required)
     2140             `(:toofew ,minargs ,required))
     2141        (and max
     2142             (> minargs max)
     2143             `(:toomany ,nargs ,max)))))
     2144
     2145(defun nx1-check-call-keywords (def bits keyvect args spread-p &aux (env *nx-lexical-environment*))
     2146  ;; Ok, if generic function, bits and keyvect are for the generic function itself.
     2147  ;; Still, since all congruent, can check whether have variable numargs
     2148  (unless (and (logbitp $lfbits-keys-bit bits)
     2149               (not spread-p)) ; last argform may contain :allow-other-keys
     2150    (return-from nx1-check-call-keywords nil))
     2151  (let* ((bad-keys nil)
     2152         (key-args (nthcdr (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)) args))
     2153         (generic-p (or (generic-function-p def)
     2154                        (and (consp def)
     2155                             (eq (def-info.function-type (cdr def)) 'defgeneric)))))
     2156    (when (oddp (length key-args))
     2157      (return-from nx1-check-call-keywords (list :odd-keywords key-args)))
     2158    (when (logbitp $lfbits-aok-bit bits)
     2159      (return-from nx1-check-call-keywords nil))
     2160    (loop for key-form in key-args by #'cddr
     2161          do (unless (nx-form-constant-p key-form env) ;; could be :aok
     2162               (return-from nx1-check-call-keywords nil))
     2163          do (let ((key (nx-form-constant-value key-form env)))
     2164               (when (eq key :allow-other-keys)
     2165                 (return-from nx1-check-call-keywords nil))
     2166               (unless (or (find key keyvect)
     2167                          (and generic-p (nx1-valid-gf-keyword-p def key)))
     2168                 (push key bad-keys))))
     2169    (when bad-keys
     2170      (if generic-p
     2171        (values (list :unknown-gf-keywords bad-keys) t)
     2172        (list :unknown-keyword (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys)) keyvect)))))
     2173
     2174(defun nx1-valid-gf-keyword-p (def key)
     2175  ;; Can assume has $lfbits-keys-bit and not $lfbits-aok-bit
     2176  (if (consp def)
     2177    (let ((definfo (cdr def)))
     2178      (assert (eq (def-info.function-type definfo) 'defgeneric))
     2179      (loop for m in (def-info.methods definfo)
     2180            thereis (multiple-value-bind (keyvect aok) (def-info-method.keyvect m)
     2181                      (or aok (find key keyvect)))))
     2182    (let ((gf (find-unencapsulated-definition def)))
     2183      (or (find key (%defgeneric-keys gf))
     2184          (loop for m in (%gf-methods gf)
     2185                thereis (let* ((func (%inner-method-function m))
     2186                               (mbits (lfun-bits func)))
     2187                          (or (and (logbitp $lfbits-aok-bit mbits)
     2188                                   ;; If no &rest, then either don't use the keyword in which case
     2189                                   ;; it's good to warn; or it's used via next-method, we'll approve
     2190                                   ;; it when we get to that method.
     2191                                   (logbitp $lfbits-rest-bit mbits))
     2192                              (find key (lfun-keyvect func)))))))))
    21572193
    21582194;;; we can save some space by going through subprims to call "builtin"
  • branches/working-0711/ccl/compiler/nx1.lisp

    r12534 r12585  
    1717(in-package "CCL")
    1818
    19 ;;; Wimp out, but don't choke on (the (values ...) form)
    2019(defnx1 nx1-the the (&whole call typespec form &environment env)
    2120  ;; Allow VALUES types here (or user-defined types that
     
    2928                           (parse-unknown-type (c)
    3029                             (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c))
    31                              nil)
     30                             *wild-type*)
    3231                           (program-error (c)
    3332                              (nx1-whine :invalid-type typespec c)
    34                               nil))))
    35              (if (null ctype)
    36                '*
    37                (if (typep ctype 'function-ctype)
    38                  'function
    39                  (nx-target-type (type-specifier (single-value-type ctype))))))))
     33                             *wild-type*))))
     34             (if (typep ctype 'function-ctype)
     35               'function
     36               (nx-target-type (type-specifier ctype))))))
    4037    (let* ((typespec (typespec-for-the typespec))
    4138           (*nx-form-type* typespec)
     
    5956          (when (eq transformed last)
    6057            (return)))
    61         (when (and (nx-form-constant-p transformed env)
    62                    (not (typep (nx-form-constant-value transformed env) typespec)))
    63           (nx1-whine :type call)
    64           (setq typespec t))
    65         (setq typespec (nx-target-type
    66                         (or (nx1-type-intersect call
    67                                                 typespec
    68                                                 (typespec-for-the (nx-form-type transformed env)))
    69                             t)))
     58        (if (and (nx-form-constant-p transformed env)
     59                 (or (equal typespec '(values))
     60                     (not (typep (nx-form-constant-value transformed env)
     61                                 (single-value-type (values-specifier-type typespec))))))
     62          (progn
     63            (nx1-whine :type call)
     64            (setq typespec '*))
     65          (setq typespec (nx-target-type
     66                          (or (nx1-type-intersect call
     67                                                  typespec
     68                                                  (typespec-for-the (nx-form-type transformed env)))
     69                              '*))))
     70        ;; Wimp out, but don't choke on (the (values ...) form)
     71        (when (and (consp typespec) (eq (car typespec) 'values))
     72          (setq typespec '*))
    7073        (make-acode
    7174         (%nx1-operator typed-form)
  • branches/working-0711/ccl/level-1/l1-error-system.lisp

    r12408 r12585  
    8484(define-condition invalid-arguments (style-warning) ())
    8585(define-condition invalid-arguments-global (style-warning) ())
     86(define-condition undefined-keyword-reference (undefined-reference invalid-arguments) ())
    8687
    8788(define-condition simple-error (simple-condition error) ())
  • branches/working-0711/ccl/level-1/l1-readloop.lisp

    r12552 r12585  
    421421
    422422
    423 (defun %cons-def-info (type &optional lfbits keyvect lambda specializers qualifiers)
     423(defun %cons-def-info (type &optional lfbits keyvect data specializers qualifiers)
    424424  (ecase type
    425425    (defun nil)
    426     (defmacro (setq lambda '(macro) lfbits nil)) ;; some code assumes lfbits=nil
    427     (defgeneric (setq lambda (list :methods)))
    428     (defmethod (setq lambda (list :methods (cons qualifiers specializers))))
    429     (deftype (setq lambda '(type) lfbits (cons nil *loading-file-source-file*))))
    430   (vector lfbits keyvect *loading-file-source-file* lambda))
     426    (defmacro (setq data '(macro) lfbits nil)) ;; some code assumes lfbits=nil
     427    (defgeneric (setq data (list :methods) lfbits (logior (ash 1 $lfbits-gfn-bit) lfbits)))
     428    (defmethod (setq data (list :methods
     429                                (%cons-def-info-method lfbits keyvect qualifiers specializers))
     430                     lfbits (logandc2 lfbits (ash 1 $lfbits-aok-bit))
     431                     keyvect nil))
     432    (deftype (setq data '(type) lfbits (cons nil *loading-file-source-file*))))
     433  (vector lfbits keyvect *loading-file-source-file* data))
    431434
    432435(defun def-info.lfbits (def-info)
     
    451454         (and (eq (car data) :methods) (%cdr data)))))
    452455
    453 (defun def-info-with-new-methods (def-info new-methods)
    454   (if (eq new-methods (def-info.methods def-info))
     456(defun %cons-def-info-method (lfbits keyvect qualifiers specializers)
     457  (cons (cons (and keyvect
     458                   (if (and (logbitp $lfbits-aok-bit lfbits)
     459                            (logbitp $lfbits-rest-bit lfbits))
     460                       (list keyvect)
     461                       keyvect))
     462              *loading-file-source-file*)
     463        (cons qualifiers specializers)))
     464
     465(defun def-info-method.keyvect (def-info-method)
     466  (let ((kv (caar def-info-method)))
     467    (if (listp kv)
     468      (values (car kv) t)
     469      (values kv  nil))))
     470
     471(defun def-info-method.file (def-info-method)
     472  (cdar def-info-method))
     473
     474(defun def-info-with-new-methods (def-info new-bits new-methods)
     475  (if (and (eq new-methods (def-info.methods def-info))
     476           (eql new-bits (def-info.lfbits def-info)))
    455477    def-info
    456     (let ((new (copy-seq def-info)))
     478    (let ((new (copy-seq def-info))
     479          (old-bits (svref def-info 0)))
     480      (setf (svref new 0) (if (consp old-bits) (cons new-bits (cdr old-bits)) old-bits))
    457481      (setf (svref new 3) (cons :methods new-methods))
    458482      new)))
     
    520544        :deftype-type (def-info.deftype-type def-info)))
    521545
     546(defun combine-gf-def-infos (name old-info new-info)
     547  (let* ((old-bits (def-info.lfbits old-info))
     548         (new-bits (def-info.lfbits new-info))
     549         (old-methods (def-info.methods old-info))
     550         (new-methods (def-info.methods new-info)))
     551    (when (and (logbitp $lfbits-gfn-bit old-bits) (logbitp $lfbits-gfn-bit new-bits))
     552      (when *compiler-warn-on-duplicate-definitions*
     553        (nx1-whine :duplicate-definition
     554                   name
     555                   (def-info.file old-info)
     556                   (def-info.file new-info)))
     557      (return-from combine-gf-def-infos new-info))
     558    (unless (congruent-lfbits-p old-bits new-bits)
     559      ;; Too bad don't have the actual lambda lists recorded.
     560      (if (logbitp $lfbits-gfn-bit new-bits)
     561        ;; A defgeneric, incongruent with previously defined methods
     562        (nx1-whine :incongruent-gf-lambda-list name)
     563        ;; A defmethod incongruent with previously defined explicit or implicit generic
     564        (nx1-whine :incongruent-method-lambda-list
     565                   (if new-methods `(:method ,@(cadar new-methods) ,name ,(cddar new-methods)) name)
     566                   name))
     567      ;; Perhaps once this happens, should just mark it somehow to not complain again
     568      (return-from combine-gf-def-infos
     569        (if (logbitp $lfbits-gfn-bit old-bits) old-info new-info)))
     570    (loop for new-method in new-methods
     571          as old = (member (cdr new-method) old-methods :test #'equal :key #'cdr)
     572          do (when old
     573               (when *compiler-warn-on-duplicate-definitions*
     574                 (nx1-whine :duplicate-definition
     575                            `(:method ,@(cadr new-method) ,name ,(cddr new-method))
     576                            (def-info-method.file (car old))
     577                            (def-info-method.file new-method)))
     578               (setq old-methods (remove (car old) old-methods :test #'eq)))
     579          do (push new-method old-methods))
     580    (cond ((logbitp $lfbits-gfn-bit new-bits)
     581           ;; If adding a defgeneric, use its info.
     582           (setq old-info new-info old-bits new-bits))
     583          ((not (logbitp $lfbits-gfn-bit old-bits))
     584           ;; If no defgeneric (yet?) just remember whether any method has &key
     585           (setq old-bits (logior old-bits (logand new-bits (ash 1 $lfbits-keys-bit))))))
     586    ;; Check that all methods implement defgeneric keys
     587    (let ((gfkeys (and (logbitp $lfbits-gfn-bit old-bits) (def-info.keyvect old-info))))
     588      (when (> (length gfkeys) 0)
     589        (loop for minfo in old-methods
     590              do (multiple-value-bind (mkeys aok) (def-info-method.keyvect minfo)
     591                   (when (and (not aok)
     592                              (setq mkeys (loop for gk across gfkeys
     593                                                unless (find gk mkeys) collect gk)))
     594                     (nx1-whine :gf-keys-not-accepted
     595                                `(:method ,@(cadr minfo) ,name ,(cddr minfo))
     596                                mkeys))))))
     597    (def-info-with-new-methods old-info old-bits old-methods)))
     598
    522599(defun combine-definition-infos (name old-info new-info)
    523   (let ((old-type (def-info.function-type old-info))  ;; defmacro
    524         (old-deftype (def-info.deftype old-info))      ;; nil
    525         (new-type (def-info.function-type new-info))  ;; nil
    526         (new-deftype (def-info.deftype new-info)))   ;; (nil . file)
     600  (let ((old-type (def-info.function-type old-info))
     601        (old-deftype (def-info.deftype old-info))
     602        (new-type (def-info.function-type new-info))
     603        (new-deftype (def-info.deftype new-info)))
    527604    (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric))
    528            ;; TODO: Check compatibility of lfbits...
    529            ;; TODO: check that all methods implement defgeneric keys
    530            (let ((old-methods (def-info.methods old-info))
    531                  (new-methods (def-info.methods new-info)))
    532              (loop for new-method in new-methods
    533                    do (if (member new-method old-methods :test #'equal)
    534                         (when *compiler-warn-on-duplicate-definitions*
    535                           (nx1-whine :duplicate-definition
    536                                      `(method ,@(car new-method) ,name ,(cdr new-method))
    537                                      (def-info.file old-info)
    538                                      (def-info.file new-info)))
    539                         (push new-method old-methods)))
    540              (setq new-info (def-info-with-new-methods old-info old-methods))))
     605           (setq new-info (combine-gf-def-infos name old-info new-info)))
    541606          ((or (eq (or old-type 'defun) (or new-type 'defun))
    542607               (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))
  • branches/working-0711/ccl/level-1/l1-typesys.lisp

    r12515 r12585  
    15101510            (setq locked t)
    15111511            (if (or (symbolp spec)
    1512                     (and (consp spec) (symbolp (car spec))))
     1512                    (and (consp spec)
     1513                         (symbolp (car spec))
     1514                         ;; hashing scheme uses equal, so only use when equivalent to eql
     1515                         (not (and (eq (car spec) 'member)
     1516                                   (some (lambda (x)
     1517                                           (typep x '(or cons string bit-vector pathname)))
     1518                                         (cdr spec))))))
    15131519              (let* ((idx (hash-type-specifier spec)))
    15141520                (incf probes)
  • branches/working-0711/ccl/level-1/sysutils.lisp

    r12515 r12585  
    563563    (undefined-type-reference (verify-deferred-type-warning w))
    564564    (undefined-function-reference (verify-deferred-function-warning w))
     565    (undefined-keyword-reference (verify-deferred-keyword-warning w))
    565566    (compiler-warning nil)))
    566567
     
    595596
    596597
     598(defun deferred-function-def (name)
     599  (let* ((defs (deferred-warnings.defs *outstanding-deferred-warnings*))
     600         (def (or (let ((cell (gethash name defs)))
     601                    (and cell (def-info.function-p (cdr cell)) cell))
     602                 (let* ((global (fboundp name)))
     603                   (and (typep global 'function) global)))))
     604    def))
     605
     606(defun check-deferred-call-args (w def wargs)
     607  (destructuring-bind (arglist spread-p) wargs
     608    (multiple-value-bind (deftype reason) (nx1-check-call-args def arglist spread-p)
     609      (when deftype
     610        (when (eq deftype :deferred-mismatch)
     611          (setq deftype (if (consp def) :environment-mismatch :global-mismatch)))
     612        (make-condition
     613         'invalid-arguments
     614         :function-name (compiler-warning-function-name w)
     615         :source-note (compiler-warning-source-note w)
     616         :warning-type deftype
     617         :args (list* (car (compiler-warning-args w)) reason arglist spread-p))))))
     618
    597619(defun verify-deferred-function-warning (w)
    598620  (let* ((args (compiler-warning-args w))
    599621         (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)))))
     622         (def (deferred-function-def wfname)))
    605623    (cond ((null def) w)
    606624          ((or (typep def 'function)
     
    609627           ;; Check args in call to forward-referenced function.
    610628           (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                                :function-name (compiler-warning-function-name w)
    618                                :source-note (compiler-warning-source-note w)
    619                                :warning-type deftype
    620                                :args (list (car args) reason arglist spread-p))))
    621                      w2))))))
     629             (check-deferred-call-args w def (cdr args))))
    622630          ((def-info.macro-p (cdr def))
    623631           (let* ((w2 (make-condition
     
    628636                       :args (list (car args)))))
    629637             w2)))))
     638
     639(defun verify-deferred-keyword-warning (w)
     640  (let* ((args (compiler-warning-args w))
     641         (wfname (car args))
     642         (def (deferred-function-def wfname)))
     643    (when def
     644      (check-deferred-call-args w def (cddr args)))))
    630645
    631646
  • branches/working-0711/ccl/lib/macros.lisp

    r12534 r12585  
    17651765      (append ll '(&allow-other-keys)))))
    17661766
    1767 (defun encode-gf-lambda-list (lambda-list)
    1768   (let* ((bits (encode-lambda-list lambda-list)))
    1769     (declare (fixnum bits))
    1770     (if (logbitp $lfbits-keys-bit bits)
    1771       (logior bits (ash 1 $lfbits-aok-bit))
    1772       bits)))
    1773 
    17741767(defmacro defmethod (name &rest args &environment env)
    17751768  (multiple-value-bind (function-form specializers-form qualifiers lambda-list documentation specializers)
     
    17781771       (eval-when (:compile-toplevel)
    17791772         (record-function-info ',(maybe-setf-function-name name)
    1780                                ',(%cons-def-info 'defmethod (encode-gf-lambda-list lambda-list) nil nil
    1781                                                  specializers qualifiers)
     1773                               ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t)
     1774                                   (%cons-def-info 'defmethod bits keyvect nil specializers qualifiers))
    17821775                               ,env))
    17831776       (compiler-let ((*nx-method-warning-name* '(,name ,@qualifiers ,specializers)))
     
    20802073         (eval-when (:compile-toplevel)
    20812074           (record-function-info ',(maybe-setf-function-name function-name)
    2082                                  ',(%cons-def-info 'defgeneric (encode-gf-lambda-list lambda-list))
     2075                                 ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t)
     2076                                     (%cons-def-info 'defgeneric bits keyvect))
    20832077                                 ,env))
    20842078         (let ((,gf (%defgeneric
Note: See TracChangeset for help on using the changeset viewer.