comparison lisp/emacs-lisp/bytecomp.el @ 83159:38500c0c86ab

Merged in changes from CVS trunk. Patches applied: * [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-398 Tweak permissions * [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-399 Tweak directory permissions * [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-400 Update from CVS * [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-401 More build-in-place tweaking of arch tagging * [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-402 Update from CVS * [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-403 Yet more build-in-place tweaking of arch tagging * [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-404 Update from CVS * [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-405 Update from CVS * [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-406 Update from CVS * [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-407 Update from CVS git-archimport-id: [e-mail]--2004/emacs--multi-tty--0--patch-199

83158:f948c9fd910c

  (let* ((new (get (car form) 'byte-obsolete-info))
	 (handler (nth 1 new))
	 (when (nth 2 new)))
    (byte-compile-set-symbol-position (car form))
    (if (memq 'obsolete byte-compile-warnings)
	(byte-compile-warn "%s is an obsolete function%s; %s" (car form)
			   (if when (concat " since " when) "")
			   (if (stringp (car new))
			       (car new)
			     (format "use %s instead." (car new)))))
    (funcall (or handler 'byte-compile-normal-call) form)))

;; Compiler options

;; (defvar byte-compiler-valid-options

(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst)
(defun byte-compile-file-form-defsubst (form)
  (when (assq (nth 1 form) byte-compile-unresolved-functions)
    (setq byte-compile-current-form (nth 1 form))
    (byte-compile-warn "defsubst %s was used before it was defined"
		       (nth 1 form)))
  (byte-compile-file-form
   (macroexpand form byte-compile-macro-environment))
  ;; Return nil so the form is not output twice.
  nil)

	   (if (and (memq 'redefine byte-compile-warnings)
		    ;; don't warn when compiling the stubs in byte-run...
		    (not (assq (nth 1 form)
			       byte-compile-initial-macro-environment)))
	       (byte-compile-warn
		 "%s defined multiple times, as both function and macro"
		 (nth 1 form)))
	   (setcdr that-one nil))
	  (this-one
	   (when (and (memq 'redefine byte-compile-warnings)
		    ;; hack: don't warn when compiling the magic internal
		    ;; byte-compiler macros in byte-run.el...
		    (not (assq (nth 1 form)
			       byte-compile-initial-macro-environment)))
	     (byte-compile-warn "%s %s defined multiple times in this file"
				(if macrop "macro" "function")
				(nth 1 form))))
	  ((and (fboundp name)
		(eq (car-safe (symbol-function name))
		    (if macrop 'lambda 'macro)))
	   (when (memq 'redefine byte-compile-warnings)
	     (byte-compile-warn "%s %s being redefined as a %s"
				(if macrop "function" "macro")
				(nth 1 form)
				(if macrop "macro" "function")))
	   ;; shadow existing definition
	   (set this-kind

	((symbolp (car form))
	 (let* ((fn (car form))
		(handler (get fn 'byte-compile)))
	   (byte-compile-set-symbol-position fn)
	   (when (byte-compile-const-symbol-p fn)
	     (byte-compile-warn "%s called as a function" fn))
	   (if (and handler
		    (or (not (byte-compile-version-cond
			      byte-compile-compatibility))
			(not (get (get fn 'byte-opcode) 'emacs19-opcode))))
	       (funcall handler form)

  (when (symbolp var)
    (byte-compile-set-symbol-position var))
  (if (or (not (symbolp var))
	  (byte-compile-const-symbol-p 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 var) "constant" "nonvariable")
       (prin1-to-string var))
    (if (and (get var 'byte-obsolete-variable)
	     (memq 'obsolete byte-compile-warnings)
	     (not (eq var byte-compile-not-obsolete-var)))
	(let* ((ob (get var 'byte-obsolete-variable))
	       (when (cdr ob)))
	  (byte-compile-warn "%s is an obsolete variable%s; %s" var
			     (if when (concat " since " when) "")
			     (if (stringp (car ob))
				 (car ob)
			       (format "use %s instead." (car ob))))))
    (if (memq 'free-vars byte-compile-warnings)
	(if (eq base-op 'byte-varbind)
	    (push var byte-compile-bound-variables)
	  (or (boundp var)
	      (memq var byte-compile-bound-variables)
	      (if (eq base-op 'byte-varset)
		  (or (memq var byte-compile-free-assignments)
		      (progn
			(byte-compile-warn "assignment to free variable %s" var)
			(push var byte-compile-free-assignments)))
		(or (memq var byte-compile-free-references)
		    (progn
		      (byte-compile-warn "reference to free variable %s" var)
		      (push var byte-compile-free-references))))))))
  (let ((tmp (assq var byte-compile-variables)))
    (unless tmp
      (setq tmp (list var))
      (push tmp byte-compile-variables))

(byte-defop-compiler-1 interactive byte-compile-noop)


(defun byte-compile-subr-wrong-args (form n)
  (byte-compile-set-symbol-position (car form))
  (byte-compile-warn "%s called with %d arg%s, but requires %s"
		     (car form) (length (cdr form))
		     (if (= 1 (length (cdr form))) "" "s") n)
  ;; get run-time wrong-number-of-args error.
  (byte-compile-normal-call form))

	  (if (stringp (car body)) (setq body (cdr body)))
	  (if (eq 'interactive (car-safe (car body))) (setq body (cdr body)))
	  (if (and (consp (car body))
		   (not (eq 'byte-code (car (car body)))))
	      (byte-compile-warn
      "A quoted lambda form is the second argument of fset.  This is probably
     not what you want, as that lambda cannot be compiled.  Consider using
     the syntax (function (lambda (...) ...)) instead.")))))
  (byte-compile-two-args form))

(defun byte-compile-funarg (form)

	  (if var (cons var byte-compile-bound-variables)
	    byte-compile-bound-variables)))
    (byte-compile-set-symbol-position 'condition-case)
    (unless (symbolp var)
      (byte-compile-warn
       "%s is not a variable-name or nil (in condition-case)" var))
    (byte-compile-push-constant var)
    (byte-compile-push-constant (byte-compile-top-level
				 (nth 2 form) for-effect))
    (let ((clauses (cdr (cdr (cdr form))))
	  compiled-clauses)

				   (if (not (symbolp (car syms)))
				       (setq ok nil))
				   (setq syms (cdr syms)))
				 ok))))
                 (byte-compile-warn
                   "%s is not a condition name or list of such (in condition-case)"
                   (prin1-to-string condition)))
;;                ((not (or (eq condition 't)
;;			  (and (stringp (get condition 'error-message))
;;			       (consp (get condition 'error-conditions)))))
;;                 (byte-compile-warn
;;                   "%s is not a known condition name (in condition-case)"
;;                   condition))
		)
	  (setq compiled-clauses
		(cons (cons condition
			    (byte-compile-top-level-body

    (byte-compile-set-symbol-position fun)
    (when (or (> (length form) 4)
	      (and (eq fun 'defconst) (null (cddr form))))
      (let ((ncall (length (cdr form))))
	(byte-compile-warn
	 "%s called with %d argument%s, but %s %s"
	 fun ncall
	 (if (= 1 ncall) "" "s")
	 (if (< ncall 2) "requires" "accepts only")
	 "2-3")))
    (when (memq 'free-vars byte-compile-warnings)

      ;; just as a real defvar would, but only in top-level forms.
      (when (and (cddr form) (null byte-compile-current-form))
	`(push ',var current-load-list))
      (when (> (length form) 3)
	(when (and string (not (stringp string)))
	  (byte-compile-warn "third arg to %s %s is not a string: %s"
			     fun var string))
	`(put ',var 'variable-documentation ,string))
      (if (cddr form)		; `value' provided
	  (let ((byte-compile-not-obsolete-var var))
	    (if (eq fun 'defconst)

83159:38500c0c86ab

  (let* ((new (get (car form) 'byte-obsolete-info))
	 (handler (nth 1 new))
	 (when (nth 2 new)))
    (byte-compile-set-symbol-position (car form))
    (if (memq 'obsolete byte-compile-warnings)
	(byte-compile-warn "`%s' is an obsolete function%s; %s" (car form)
			   (if when (concat " since " when) "")
			   (if (stringp (car new))
			       (car new)
			     (format "use `%s' instead." (car new)))))
    (funcall (or handler 'byte-compile-normal-call) form)))

;; Compiler options

;; (defvar byte-compiler-valid-options

(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst)
(defun byte-compile-file-form-defsubst (form)
  (when (assq (nth 1 form) byte-compile-unresolved-functions)
    (setq byte-compile-current-form (nth 1 form))
    (byte-compile-warn "defsubst `%s' was used before it was defined"
		       (nth 1 form)))
  (byte-compile-file-form
   (macroexpand form byte-compile-macro-environment))
  ;; Return nil so the form is not output twice.
  nil)

	   (if (and (memq 'redefine byte-compile-warnings)
		    ;; don't warn when compiling the stubs in byte-run...
		    (not (assq (nth 1 form)
			       byte-compile-initial-macro-environment)))
	       (byte-compile-warn
		 "`%s' defined multiple times, as both function and macro"
		 (nth 1 form)))
	   (setcdr that-one nil))
	  (this-one
	   (when (and (memq 'redefine byte-compile-warnings)
		    ;; hack: don't warn when compiling the magic internal
		    ;; byte-compiler macros in byte-run.el...
		    (not (assq (nth 1 form)
			       byte-compile-initial-macro-environment)))
	     (byte-compile-warn "%s `%s' defined multiple times in this file"
				(if macrop "macro" "function")
				(nth 1 form))))
	  ((and (fboundp name)
		(eq (car-safe (symbol-function name))
		    (if macrop 'lambda 'macro)))
	   (when (memq 'redefine byte-compile-warnings)
	     (byte-compile-warn "%s `%s' being redefined as a %s"
				(if macrop "function" "macro")
				(nth 1 form)
				(if macrop "macro" "function")))
	   ;; shadow existing definition
	   (set this-kind

	((symbolp (car form))
	 (let* ((fn (car form))
		(handler (get fn 'byte-compile)))
	   (byte-compile-set-symbol-position fn)
	   (when (byte-compile-const-symbol-p fn)
	     (byte-compile-warn "`%s' called as a function" fn))
	   (if (and handler
		    (or (not (byte-compile-version-cond
			      byte-compile-compatibility))
			(not (get (get fn 'byte-opcode) 'emacs19-opcode))))
	       (funcall handler form)

  (when (symbolp var)
    (byte-compile-set-symbol-position var))
  (if (or (not (symbolp var))
	  (byte-compile-const-symbol-p 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 var) "constant" "nonvariable")
       (prin1-to-string var))
    (if (and (get var 'byte-obsolete-variable)
	     (memq 'obsolete byte-compile-warnings)
	     (not (eq var byte-compile-not-obsolete-var)))
	(let* ((ob (get var 'byte-obsolete-variable))
	       (when (cdr ob)))
	  (byte-compile-warn "`%s' is an obsolete variable%s; %s" var
			     (if when (concat " since " when) "")
			     (if (stringp (car ob))
				 (car ob)
			       (format "use `%s' instead." (car ob))))))
    (if (memq 'free-vars byte-compile-warnings)
	(if (eq base-op 'byte-varbind)
	    (push var byte-compile-bound-variables)
	  (or (boundp var)
	      (memq var byte-compile-bound-variables)
	      (if (eq base-op 'byte-varset)
		  (or (memq var byte-compile-free-assignments)
		      (progn
			(byte-compile-warn "assignment to free variable `%s'" var)
			(push var byte-compile-free-assignments)))
		(or (memq var byte-compile-free-references)
		    (progn
		      (byte-compile-warn "reference to free variable `%s'" var)
		      (push var byte-compile-free-references))))))))
  (let ((tmp (assq var byte-compile-variables)))
    (unless tmp
      (setq tmp (list var))
      (push tmp byte-compile-variables))

(byte-defop-compiler-1 interactive byte-compile-noop)


(defun byte-compile-subr-wrong-args (form n)
  (byte-compile-set-symbol-position (car form))
  (byte-compile-warn "`%s' called with %d arg%s, but requires %s"
		     (car form) (length (cdr form))
		     (if (= 1 (length (cdr form))) "" "s") n)
  ;; get run-time wrong-number-of-args error.
  (byte-compile-normal-call form))

	  (if (stringp (car body)) (setq body (cdr body)))
	  (if (eq 'interactive (car-safe (car body))) (setq body (cdr body)))
	  (if (and (consp (car body))
		   (not (eq 'byte-code (car (car body)))))
	      (byte-compile-warn
      "A quoted lambda form is the second argument of `fset'.  This is probably
     not what you want, as that lambda cannot be compiled.  Consider using
     the syntax (function (lambda (...) ...)) instead.")))))
  (byte-compile-two-args form))

(defun byte-compile-funarg (form)

	  (if var (cons var byte-compile-bound-variables)
	    byte-compile-bound-variables)))
    (byte-compile-set-symbol-position 'condition-case)
    (unless (symbolp var)
      (byte-compile-warn
       "`%s' is not a variable-name or nil (in condition-case)" var))
    (byte-compile-push-constant var)
    (byte-compile-push-constant (byte-compile-top-level
				 (nth 2 form) for-effect))
    (let ((clauses (cdr (cdr (cdr form))))
	  compiled-clauses)

				   (if (not (symbolp (car syms)))
				       (setq ok nil))
				   (setq syms (cdr syms)))
				 ok))))
                 (byte-compile-warn
                   "`%s' is not a condition name or list of such (in condition-case)"
                   (prin1-to-string condition)))
;;                ((not (or (eq condition 't)
;;			  (and (stringp (get condition 'error-message))
;;			       (consp (get condition 'error-conditions)))))
;;                 (byte-compile-warn
;;                   "`%s' is not a known condition name (in condition-case)"
;;                   condition))
		)
	  (setq compiled-clauses
		(cons (cons condition
			    (byte-compile-top-level-body

    (byte-compile-set-symbol-position fun)
    (when (or (> (length form) 4)
	      (and (eq fun 'defconst) (null (cddr form))))
      (let ((ncall (length (cdr form))))
	(byte-compile-warn
	 "`%s' called with %d argument%s, but %s %s"
	 fun ncall
	 (if (= 1 ncall) "" "s")
	 (if (< ncall 2) "requires" "accepts only")
	 "2-3")))
    (when (memq 'free-vars byte-compile-warnings)

      ;; just as a real defvar would, but only in top-level forms.
      (when (and (cddr form) (null byte-compile-current-form))
	`(push ',var current-load-list))
      (when (> (length form) 3)
	(when (and string (not (stringp string)))
	  (byte-compile-warn "third arg to `%s %s' is not a string: %s"
			     fun var string))
	`(put ',var 'variable-documentation ,string))
      (if (cddr form)		; `value' provided
	  (let ((byte-compile-not-obsolete-var var))
	    (if (eq fun 'defconst)