diff lisp/emacs-lisp/bytecomp.el @ 105806:83e7d269fc49

(byte-compile-warning-types, byte-compile-warnings): Add `constants' as an option. (byte-compile-callargs-warn, byte-compile-arglist-warn) (display-call-tree): Update for byte-compile-fdefinition possibly returning `(macro lambda ...)'. (Bug#4778) (byte-compile-variable-ref, byte-compile-setq-default): Respect `constants' member of byte-compile-warnings.

--- a/lisp/emacs-lisp/bytecomp.el	Sat Oct 31 02:05:15 2009 +0000
+++ b/lisp/emacs-lisp/bytecomp.el	Sat Oct 31 02:10:43 2009 +0000
@@ -66,47 +66,7 @@
 ;;  + correct compilation of top-level uses of macros;
 ;;  + the ability to generate a histogram of functions called.
 
-;; User customization variables:
-;;
-;; byte-compile-verbose	Whether to report the function currently being
-;;				compiled in the echo area;
-;; byte-optimize		Whether to do optimizations; this may be
-;;				t, nil, 'source, or 'byte;
-;; byte-optimize-log		Whether to report (in excruciating detail)
-;;				exactly which optimizations have been made.
-;;				This may be t, nil, 'source, or 'byte;
-;; byte-compile-error-on-warn	Whether to stop compilation when a warning is
-;;				produced;
-;; byte-compile-delete-errors	Whether the optimizer may delete calls or
-;;				variable references that are side-effect-free
-;;				except that they may return an error.
-;; byte-compile-generate-call-tree	Whether to generate a histogram of
-;;				function calls.  This can be useful for
-;;				finding unused functions, as well as simple
-;;				performance metering.
-;; byte-compile-warnings	List of warnings to issue, or t.  May contain
-;;				`free-vars' (references to variables not in the
-;;					     current lexical scope)
-;;				`unresolved' (calls to unknown functions)
-;;				`callargs'  (lambda calls with args that don't
-;;					     match the lambda's definition)
-;;				`redefine'  (function cell redefined from
-;;					     a macro to a lambda or vice versa,
-;;					     or redefined to take other args)
-;;				`obsolete'  (obsolete variables and functions)
-;;				`noruntime' (calls to functions only defined
-;;					     within `eval-when-compile')
-;;				`cl-functions' (calls to CL functions)
-;;				`interactive-only' (calls to commands that are
-;;						   not good to call from Lisp)
-;;				`make-local' (dubious calls to
-;;					      `make-variable-buffer-local')
-;;                              `mapcar'     (mapcar called for effect)
-;; byte-compile-compatibility	Whether the compiler should
-;;				generate .elc files which can be loaded into
-;;				generic emacs 18.
-;; emacs-lisp-file-regexp	Regexp for the extension of source-files;
-;;				see also the function byte-compile-dest-file.
+;; User customization variables: M-x customize-group bytecomp
 
 ;; New Features:
 ;;
@@ -349,7 +309,7 @@
 (defconst byte-compile-warning-types
   '(redefine callargs free-vars unresolved
 	     obsolete noruntime cl-functions interactive-only
-	     make-local mapcar)
+	     make-local mapcar constants)
   "The list of warning types used when `byte-compile-warnings' is t.")
 (defcustom byte-compile-warnings t
   "List of warnings that the byte-compiler should issue (t for all).
@@ -370,6 +330,7 @@
 	      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.
+  constants   let-binding of, or assignment to, constants/nonvariables.
 
 If the list begins with `not', then the remaining elements specify warnings to
 suppress.  For example, (not mapcar) will suppress warnings about mapcar."
@@ -380,7 +341,7 @@
 		      (const callargs) (const redefine)
 		      (const obsolete) (const noruntime)
 		      (const cl-functions) (const interactive-only)
-		      (const make-local) (const mapcar))))
+		      (const make-local) (const mapcar) (const constants))))
 ;;;###autoload(put 'byte-compile-warnings 'safe-local-variable 'byte-compile-warnings-safe-p)
 
 ;;;###autoload
@@ -1306,12 +1267,16 @@
   (let* ((def (or (byte-compile-fdefinition (car form) nil)
 		  (byte-compile-fdefinition (car form) t)))
 	 (sig (if (and def (not (eq def t)))
-		  (byte-compile-arglist-signature
-		   (if (memq (car-safe def) '(declared lambda))
-		       (nth 1 def)
-		     (if (byte-code-function-p def)
-			 (aref def 0)
-		       '(&rest def))))
+		  (progn
+		    (and (eq (car-safe def) 'macro)
+			 (eq (car-safe (cdr-safe def)) 'lambda)
+			 (setq def (cdr def)))
+		    (byte-compile-arglist-signature
+		     (if (memq (car-safe def) '(declared lambda))
+			 (nth 1 def)
+		       (if (byte-code-function-p def)
+			   (aref def 0)
+			 '(&rest def)))))
 		(if (and (fboundp (car form))
 			 (subrp (symbol-function (car form))))
 		    (subr-arity (symbol-function (car form))))))
@@ -1406,22 +1371,26 @@
 (defun byte-compile-arglist-warn (form macrop)
   (let ((old (byte-compile-fdefinition (nth 1 form) macrop)))
     (if (and old (not (eq old t)))
-	(let ((sig1 (byte-compile-arglist-signature
-		      (if (eq 'lambda (car-safe old))
-			  (nth 1 old)
-			(if (byte-code-function-p old)
-			    (aref old 0)
-			  '(&rest def)))))
-	      (sig2 (byte-compile-arglist-signature (nth 2 form))))
-	  (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2)
-	    (byte-compile-set-symbol-position (nth 1 form))
-	    (byte-compile-warn
-	     "%s %s used to take %s %s, now takes %s"
-	     (if (eq (car form) 'defun) "function" "macro")
-	     (nth 1 form)
-	     (byte-compile-arglist-signature-string sig1)
-	     (if (equal sig1 '(1 . 1)) "argument" "arguments")
-	     (byte-compile-arglist-signature-string sig2))))
+	(progn
+	  (and (eq 'macro (car-safe old))
+	       (eq 'lambda (car-safe (cdr-safe old)))
+	       (setq old (cdr old)))
+	  (let ((sig1 (byte-compile-arglist-signature
+		       (if (eq 'lambda (car-safe old))
+			   (nth 1 old)
+			 (if (byte-code-function-p old)
+			     (aref old 0)
+			   '(&rest def)))))
+		(sig2 (byte-compile-arglist-signature (nth 2 form))))
+	    (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2)
+	      (byte-compile-set-symbol-position (nth 1 form))
+	      (byte-compile-warn
+	       "%s %s used to take %s %s, now takes %s"
+	       (if (eq (car form) 'defun) "function" "macro")
+	       (nth 1 form)
+	       (byte-compile-arglist-signature-string sig1)
+	       (if (equal sig1 '(1 . 1)) "argument" "arguments")
+	       (byte-compile-arglist-signature-string sig2)))))
       ;; This is the first definition.  See if previous calls are compatible.
       (let ((calls (assq (nth 1 form) byte-compile-unresolved-functions))
 	    nums sig min max)
@@ -3046,12 +3015,13 @@
   (if (or (not (symbolp bytecomp-var))
 	  (byte-compile-const-symbol-p bytecomp-var
 				       (not (eq base-op 'byte-varref))))
-      (byte-compile-warn
-       (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'")
-	     ((eq base-op 'byte-varset) "variable assignment to %s `%s'")
-	     (t "variable reference to %s `%s'"))
-       (if (symbolp bytecomp-var) "constant" "nonvariable")
-       (prin1-to-string bytecomp-var))
+      (if (byte-compile-warning-enabled-p 'constants)
+	  (byte-compile-warn
+	   (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'")
+		 ((eq base-op 'byte-varset) "variable assignment to %s `%s'")
+		 (t "variable reference to %s `%s'"))
+	   (if (symbolp bytecomp-var) "constant" "nonvariable")
+	   (prin1-to-string bytecomp-var)))
     (and (get bytecomp-var 'byte-obsolete-variable)
 	 (not (memq bytecomp-var byte-compile-not-obsolete-vars))
 	 (byte-compile-warn-obsolete bytecomp-var))
@@ -3582,12 +3552,13 @@
 	setters)
     (while bytecomp-args
       (let ((var (car bytecomp-args)))
-	(if (or (not (symbolp var))
-		(byte-compile-const-symbol-p var t))
-	    (byte-compile-warn
-	     "variable assignment to %s `%s'"
-	     (if (symbolp var) "constant" "nonvariable")
-	     (prin1-to-string var)))
+	(and (or (not (symbolp var))
+		 (byte-compile-const-symbol-p var t))
+	     (byte-compile-warning-enabled-p 'constants)
+	     (byte-compile-warn
+	      "variable assignment to %s `%s'"
+	      (if (symbolp var) "constant" "nonvariable")
+	      (prin1-to-string var)))
 	(push (list 'set-default (list 'quote var) (car (cdr bytecomp-args)))
 	      setters))
       (setq bytecomp-args (cdr (cdr bytecomp-args))))
@@ -4329,12 +4300,22 @@
 
       (message "Generating call tree...(finding uncalled functions...)")
       (setq rest byte-compile-call-tree)
-      (let ((uncalled nil))
+      (let (uncalled def)
 	(while rest
 	  (or (nth 1 (car rest))
-	      (null (setq f (car (car rest))))
-	      (functionp (byte-compile-fdefinition f t))
-	      (commandp (byte-compile-fdefinition f nil))
+	      (null (setq f (caar rest)))
+	      (progn
+		(setq def (byte-compile-fdefinition f t))
+		(and (eq (car-safe def) 'macro)
+		     (eq (car-safe (cdr-safe def)) 'lambda)
+		     (setq def (cdr def)))
+		(functionp def))
+	      (progn
+		(setq def (byte-compile-fdefinition f nil))
+		(and (eq (car-safe def) 'macro)
+		     (eq (car-safe (cdr-safe def)) 'lambda)
+		     (setq def (cdr def)))
+		(commandp def))
 	      (setq uncalled (cons f uncalled)))
 	  (setq rest (cdr rest)))
 	(if uncalled
@@ -4342,10 +4323,8 @@
 	      (insert "Noninteractive functions not known to be called:\n  ")
 	      (setq p (point))
 	      (insert (mapconcat 'symbol-name (nreverse uncalled) ", "))
-	      (fill-region-as-paragraph p (point)))))
-      )
-    (message "Generating call tree...done.")
-    ))
+	      (fill-region-as-paragraph p (point))))))
+    (message "Generating call tree...done.")))
 
 
 ;;;###autoload