diff lisp/emacs-lisp/bytecomp.el @ 91085:880960b70474

Merge from emacs--devo--0 Revision: [e-mail]/emacs--unicode--0--patch-283

--- a/lisp/emacs-lisp/bytecomp.el	Fri Nov 09 14:52:32 2007 +0000
+++ b/lisp/emacs-lisp/bytecomp.el	Sun Nov 11 00:56:44 2007 +0000
@@ -362,7 +362,10 @@
   interactive-only
 	      commands that normally shouldn't be called from Lisp code.
   make-local  calls to make-variable-buffer-local that may be incorrect.
-  mapcar      mapcar called for effect."
+  mapcar      mapcar called for effect.
+
+If the list begins with `not', then the remaining elements specify warnings to
+suppress.  For example, (not mapcar) will suppress warnings about mapcar."
   :group 'bytecomp
   :type `(choice (const :tag "All" t)
 		 (set :menu-tag "Some"
@@ -377,6 +380,8 @@
 (defun byte-compile-warnings-safe-p (x)
   (or (booleanp x)
       (and (listp x)
+           (if (eq (car x) 'not) (setq x (cdr x))
+             t)
 	   (equal (mapcar
 		   (lambda (e)
 		     (when (memq e '(free-vars unresolved
@@ -388,6 +393,46 @@
 		   x)
 		  x))))
 
+(defun byte-compile-warning-enabled-p (warning)
+  "Return non-nil if WARNING is enabled, according to `byte-compile-warnings'."
+  (or (eq byte-compile-warnings t)
+      (if (eq (car byte-compile-warnings) 'not)
+          (not (memq warning byte-compile-warnings))
+        (memq warning byte-compile-warnings))))
+
+;;;###autoload
+(defun byte-compile-disable-warning (warning)
+  "Change `byte-compile-warnings' to disable WARNING.
+If `byte-compile-warnings' is t, set it to `(not WARNING)'.
+Otherwise, if the first element is `not', add WARNING, else remove it.
+Normally you should let-bind `byte-compile-warnings' before calling this,
+else the global value will be modified."
+  (setq byte-compile-warnings
+        (cond ((eq byte-compile-warnings t)
+               (list 'not warning))
+              ((eq (car byte-compile-warnings) 'not)
+               (if (memq warning byte-compile-warnings)
+                   byte-compile-warnings
+                 (append byte-compile-warnings (list warning))))
+              (t
+               (delq warning byte-compile-warnings)))))
+
+;;;###autoload
+(defun byte-compile-enable-warning (warning)
+  "Change `byte-compile-warnings' to enable WARNING.
+If `byte-compile-warnings' is `t', do nothing.  Otherwise, if the
+first element is `not', remove WARNING, else add it.
+Normally you should let-bind `byte-compile-warnings' before calling this,
+else the global value will be modified."
+  (or (eq byte-compile-warnings t)
+      (setq byte-compile-warnings
+            (cond ((eq (car byte-compile-warnings) 'not)
+                   (delq warning byte-compile-warnings))
+                  ((memq warning byte-compile-warnings)
+                   byte-compile-warnings)
+                  (t
+                   (append byte-compile-warnings (list warning)))))))
+
 (defvar byte-compile-interactive-only-functions
   '(beginning-of-buffer end-of-buffer replace-string replace-regexp
     insert-file insert-buffer insert-file-literally previous-line next-line)
@@ -830,7 +875,7 @@
   (let ((hist-orig load-history)
 	(hist-nil-orig current-load-list))
     (prog1 (eval form)
-      (when (memq 'noruntime byte-compile-warnings)
+      (when (byte-compile-warning-enabled-p 'noruntime)
 	(let ((hist-new load-history)
 	      (hist-nil-new current-load-list))
 	  ;; Go through load-history, look for newly loaded files
@@ -858,7 +903,7 @@
 		  (push s byte-compile-noruntime-functions))
 		(when (and (consp s) (eq t (car s)))
 		  (push (cdr s) old-autoloads)))))))
-      (when (memq 'cl-functions byte-compile-warnings)
+      (when (byte-compile-warning-enabled-p 'cl-functions)
 	(let ((hist-new load-history))
 	  ;; Go through load-history, look for newly loaded files
 	  ;; and mark all the functions defined therein.
@@ -876,8 +921,7 @@
       (let ((tem current-load-list))
 	(while (not (eq tem hist-nil-orig))
 	  (when (equal (car tem) '(require . cl))
-	    (setq byte-compile-warnings
-		  (remq 'cl-functions byte-compile-warnings)))
+            (byte-compile-disable-warning 'cl-functions))
 	  (setq tem (cdr tem)))))))
 
 ;;; byte compiler messages
@@ -1075,7 +1119,7 @@
 	 (handler (nth 1 new))
 	 (when (nth 2 new)))
     (byte-compile-set-symbol-position (car form))
-    (if (memq 'obsolete byte-compile-warnings)
+    (if (byte-compile-warning-enabled-p 'obsolete)
 	(byte-compile-warn "`%s' is an obsolete function%s; %s" (car form)
 			   (if when (concat " (as of Emacs " when ")") "")
 			   (if (stringp (car new))
@@ -1421,7 +1465,7 @@
 ;; defined, issue a warning enumerating them.
 ;; `unresolved' in the list `byte-compile-warnings' disables this.
 (defun byte-compile-warn-about-unresolved-functions ()
-  (when (memq 'unresolved byte-compile-warnings)
+  (when (byte-compile-warning-enabled-p 'unresolved)
     (let ((byte-compile-current-form :end)
 	  (noruntime nil)
 	  (unresolved nil))
@@ -1484,9 +1528,7 @@
 		 byte-compile-dynamic-docstrings)
 ;; 		(byte-compile-generate-emacs19-bytecodes
 ;; 		 byte-compile-generate-emacs19-bytecodes)
-		(byte-compile-warnings (if (eq byte-compile-warnings t)
-					   byte-compile-warning-types
-					 byte-compile-warnings))
+		(byte-compile-warnings byte-compile-warnings)
 		)
 	      body)))
 
@@ -1829,9 +1871,7 @@
 	(read-with-symbol-positions inbuffer)
 	(read-symbol-positions-list nil)
 	;;	  #### This is bound in b-c-close-variables.
-	;;	  (byte-compile-warnings (if (eq byte-compile-warnings t)
-	;;				     byte-compile-warning-types
-	;;				   byte-compile-warnings))
+	;;	  (byte-compile-warnings byte-compile-warnings)
 	)
     (byte-compile-close-variables
      (with-current-buffer
@@ -2210,7 +2250,7 @@
       ;; Since there is no doc string, we can compile this as a normal form,
       ;; and not do a file-boundary.
       (byte-compile-keep-pending form)
-    (when (memq 'free-vars byte-compile-warnings)
+    (when (byte-compile-warning-enabled-p 'free-vars)
       (push (nth 1 form) byte-compile-bound-variables)
       (if (eq (car form) 'defconst)
 	  (push (nth 1 form) byte-compile-const-variables)))
@@ -2220,12 +2260,19 @@
 		   (byte-compile-top-level (nth 2 form) nil 'file))))
     form))
 
+(put 'define-abbrev-table 'byte-hunk-handler 'byte-compile-file-form-define-abbrev-table)
+(defun byte-compile-file-form-define-abbrev-table (form)
+  (when (and (byte-compile-warning-enabled-p 'free-vars)
+             (eq 'quote (car-safe (car-safe (cdr form)))))
+    (push (car-safe (cdr (cadr form))) byte-compile-bound-variables))
+  (byte-compile-keep-pending form))
+
 (put 'custom-declare-variable 'byte-hunk-handler
      'byte-compile-file-form-custom-declare-variable)
 (defun byte-compile-file-form-custom-declare-variable (form)
-  (when (memq 'callargs byte-compile-warnings)
+  (when (byte-compile-warning-enabled-p 'callargs)
     (byte-compile-nogroup-warn form))
-  (when (memq 'free-vars byte-compile-warnings)
+  (when (byte-compile-warning-enabled-p 'free-vars)
     (push (nth 1 (nth 1 form)) byte-compile-bound-variables))
   (let ((tail (nthcdr 4 form)))
     (while tail
@@ -2248,8 +2295,7 @@
     (apply 'require args)
     ;; Detect (require 'cl) in a way that works even if cl is already loaded.
     (if (member (car args) '("cl" cl))
-	(setq byte-compile-warnings
-	      (remq 'cl-functions byte-compile-warnings))))
+        (byte-compile-disable-warning 'cl-functions)))
   (byte-compile-keep-pending form 'byte-compile-normal-call))
 
 (put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
@@ -2295,12 +2341,12 @@
 		  (cons (list name nil nil) byte-compile-call-tree))))
 
     (setq byte-compile-current-form name) ; for warnings
-    (if (memq 'redefine byte-compile-warnings)
+    (if (byte-compile-warning-enabled-p 'redefine)
 	(byte-compile-arglist-warn form macrop))
     (if byte-compile-verbose
 	(message "Compiling %s... (%s)" (or filename "") (nth 1 form)))
     (cond (that-one
-	   (if (and (memq 'redefine byte-compile-warnings)
+	   (if (and (byte-compile-warning-enabled-p 'redefine)
 		    ;; don't warn when compiling the stubs in byte-run...
 		    (not (assq (nth 1 form)
 			       byte-compile-initial-macro-environment)))
@@ -2309,7 +2355,7 @@
 		 (nth 1 form)))
 	   (setcdr that-one nil))
 	  (this-one
-	   (when (and (memq 'redefine byte-compile-warnings)
+	   (when (and (byte-compile-warning-enabled-p 'redefine)
 		    ;; hack: don't warn when compiling the magic internal
 		    ;; byte-compiler macros in byte-run.el...
 		    (not (assq (nth 1 form)
@@ -2320,7 +2366,7 @@
 	  ((and (fboundp name)
 		(eq (car-safe (symbol-function name))
 		    (if macrop 'lambda 'macro)))
-	   (when (memq 'redefine byte-compile-warnings)
+	   (when (byte-compile-warning-enabled-p 'redefine)
 	     (byte-compile-warn "%s `%s' being redefined as a %s"
 				(if macrop "function" "macro")
 				(nth 1 form)
@@ -2560,7 +2606,7 @@
   (byte-compile-check-lambda-list (nth 1 fun))
   (let* ((arglist (nth 1 fun))
 	 (byte-compile-bound-variables
-	  (nconc (and (memq 'free-vars byte-compile-warnings)
+	  (nconc (and (byte-compile-warning-enabled-p 'free-vars)
 		      (delq '&rest (delq '&optional (copy-sequence arglist))))
 		 byte-compile-bound-variables))
 	 (body (cdr (cdr fun)))
@@ -2800,7 +2846,7 @@
 		(handler (get fn 'byte-compile)))
 	   (when (byte-compile-const-symbol-p fn)
 	     (byte-compile-warn "`%s' called as a function" fn))
-	   (and (memq 'interactive-only byte-compile-warnings)
+	   (and (byte-compile-warning-enabled-p 'interactive-only)
 		(memq fn byte-compile-interactive-only-functions)
 		(byte-compile-warn "`%s' used from Lisp code\n\
 That command is designed for interactive use only" fn))
@@ -2815,12 +2861,12 @@
                                byte-compile-compatibility)
                               (get (get fn 'byte-opcode) 'emacs19-opcode))))
                (funcall handler form)
-	     (when (memq 'callargs byte-compile-warnings)
+	     (when (byte-compile-warning-enabled-p 'callargs)
 	       (if (memq fn '(custom-declare-group custom-declare-variable custom-declare-face))
 		   (byte-compile-nogroup-warn form))
 	       (byte-compile-callargs-warn form))
 	     (byte-compile-normal-call form))
-	   (if (memq 'cl-functions byte-compile-warnings)
+	   (if (byte-compile-warning-enabled-p 'cl-functions)
 	       (byte-compile-cl-warn form))))
 	((and (or (byte-code-function-p (car form))
 		  (eq (car-safe (car form)) 'lambda))
@@ -2837,7 +2883,7 @@
   (if byte-compile-generate-call-tree
       (byte-compile-annotate-call-tree form))
   (when (and for-effect (eq (car form) 'mapcar)
-	     (memq 'mapcar byte-compile-warnings))
+             (byte-compile-warning-enabled-p 'mapcar))
     (byte-compile-set-symbol-position 'mapcar)
     (byte-compile-warn
      "`mapcar' called for effect; use `mapc' or `dolist' instead"))
@@ -2857,7 +2903,7 @@
        (if (symbolp var) "constant" "nonvariable")
        (prin1-to-string var))
     (if (and (get var 'byte-obsolete-variable)
-	     (memq 'obsolete byte-compile-warnings)
+	     (byte-compile-warning-enabled-p 'obsolete)
 	     (not (eq var byte-compile-not-obsolete-var)))
 	(let* ((ob (get var 'byte-obsolete-variable))
 	       (when (cdr ob)))
@@ -2866,7 +2912,7 @@
 			     (if (stringp (car ob))
 				 (car ob)
 			       (format "use `%s' instead." (car ob))))))
-    (if (memq 'free-vars byte-compile-warnings)
+    (if (byte-compile-warning-enabled-p 'free-vars)
 	(if (eq base-op 'byte-varbind)
 	    (push var byte-compile-bound-variables)
 	  (or (boundp var)
@@ -3448,6 +3494,32 @@
       (if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop))
     ,tag))
 
+;; Return the list of items in CONDITION-PARAM that match PRED-LIST.
+;; Only return items that are not in ONLY-IF-NOT-PRESENT.
+(defun byte-compile-find-bound-condition (condition-param 
+					  pred-list 
+					  &optional only-if-not-present)
+  (let ((result nil)
+	(nth-one nil)
+	(cond-list 
+	 (if (memq (car-safe condition-param) pred-list)
+	     ;; The condition appears by itself.
+	     (list condition-param)
+	   ;; If the condition is an `and', look for matches among the
+	   ;; `and' arguments.
+	   (when (eq 'and (car-safe condition-param))
+	     (cdr condition-param)))))
+    
+    (dolist (crt cond-list)
+      (when (and (memq (car-safe crt) pred-list)
+		 (eq 'quote (car-safe (setq nth-one (nth 1 crt))))
+		 ;; Ignore if the symbol is already on the unresolved
+		 ;; list.
+		 (not (assq (nth 1 nth-one) ; the relevant symbol
+			    only-if-not-present)))
+	(push (nth 1 (nth 1 crt)) result)))
+    result))
+
 (defmacro byte-compile-maybe-guarded (condition &rest body)
   "Execute forms in BODY, potentially guarded by CONDITION.
 CONDITION is a variable whose value is a test in an `if' or `cond'.
@@ -3459,35 +3531,34 @@
 If CONDITION's value is (not (featurep 'emacs)) or (featurep 'xemacs),
 that suppresses all warnings during execution of BODY."
   (declare (indent 1) (debug t))
-  `(let* ((fbound
-	   (if (eq 'fboundp (car-safe ,condition))
-	       (and (eq 'quote (car-safe (nth 1 ,condition)))
-		    ;; Ignore if the symbol is already on the
-		    ;; unresolved list.
-		    (not (assq (nth 1 (nth 1 ,condition)) ; the relevant symbol
-			       byte-compile-unresolved-functions))
-		    (nth 1 (nth 1 ,condition)))))
-	  (bound (if (or (eq 'boundp (car-safe ,condition))
-			 (eq 'default-boundp (car-safe ,condition)))
-		     (and (eq 'quote (car-safe (nth 1 ,condition)))
-			  (nth 1 (nth 1 ,condition)))))
+  `(let* ((fbound-list (byte-compile-find-bound-condition 
+			,condition (list 'fboundp) 
+			byte-compile-unresolved-functions))
+	  (bound-list (byte-compile-find-bound-condition 
+		       ,condition (list 'boundp 'default-boundp)))
 	  ;; Maybe add to the bound list.
 	  (byte-compile-bound-variables
-	   (if bound
-	       (cons bound byte-compile-bound-variables)
+	   (if bound-list
+	       (append bound-list byte-compile-bound-variables)
 	     byte-compile-bound-variables))
 	  ;; Suppress all warnings, for code not used in Emacs.
-	  (byte-compile-warnings
-	   (if (member ,condition '((featurep 'xemacs)
-				    (not (featurep 'emacs))))
-	       nil byte-compile-warnings)))
+	  ;; FIXME: by the time this is executed the `featurep'
+	  ;; emacs/xemacs tests have been optimized away, so this is
+	  ;; not doing anything useful here, is should probably be
+	  ;; moved to a different place.
+	  ;; (byte-compile-warnings
+	  ;;  (if (member ,condition '((featurep 'xemacs)
+	  ;; 			    (not (featurep 'emacs))))
+	  ;;      nil byte-compile-warnings))
+	  )
      (unwind-protect
 	 (progn ,@body)
        ;; Maybe remove the function symbol from the unresolved list.
-       (if fbound
+       (dolist (fbound fbound-list)
+	 (when fbound
 	   (setq byte-compile-unresolved-functions
 		 (delq (assq fbound byte-compile-unresolved-functions)
-		       byte-compile-unresolved-functions))))))
+		       byte-compile-unresolved-functions)))))))
 
 (defun byte-compile-if (form)
   (byte-compile-form (car (cdr form)))
@@ -3809,7 +3880,7 @@
 	 (if (= 1 ncall) "" "s")
 	 (if (< ncall 2) "requires" "accepts only")
 	 "2-3")))
-    (when (memq 'free-vars byte-compile-warnings)
+    (when (byte-compile-warning-enabled-p 'free-vars)
       (push var byte-compile-bound-variables)
       (if (eq fun 'defconst)
 	  (push var byte-compile-const-variables)))
@@ -3901,7 +3972,7 @@
 (byte-defop-compiler-1 make-variable-buffer-local byte-compile-make-variable-buffer-local)
 (defun byte-compile-make-variable-buffer-local (form)
   (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote)
-           (memq 'make-local byte-compile-warnings))
+           (byte-compile-warning-enabled-p 'make-local))
       (byte-compile-warn
        "`make-variable-buffer-local' should be called at toplevel"))
   (byte-compile-normal-call form))