Mercurial > hg > xemacs-beta
diff lisp/bytecomp.el @ 380:8626e4521993 r21-2-5
Import from CVS: tag r21-2-5
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 11:07:10 +0200 |
| parents | 6240c7796c7a |
| children | 74fd4e045ea6 |
line wrap: on
line diff
--- a/lisp/bytecomp.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/bytecomp.el Mon Aug 13 11:07:10 2007 +0200 @@ -9,7 +9,7 @@ ;; Subsequently modified by RMS and others. -(defconst byte-compile-version (purecopy "2.25 XEmacs; 22-Mar-96.")) +(defconst byte-compile-version (purecopy "2.26 XEmacs; 1998-10-07.")) ;; This file is part of XEmacs. @@ -101,6 +101,8 @@ ;;; 'unresolved (calls to unknown functions) ;;; 'callargs (lambda calls with args that don't ;;; match the lambda's definition) +;;; 'subr-callargs (calls to subrs with args that +;;; don't match the subr's definition) ;;; 'redefine (function cell redefined from ;;; a macro to a lambda or vice versa, ;;; or redefined to take other args) @@ -171,7 +173,7 @@ ;;; buffer, and that buffer is modified, you are asked whether you want ;;; to save the buffer before compiling. ;;; -;;; o You can add this to /etc/magic to make file(1) recognise the files +;;; o You can add this to /etc/magic to make file(1) recognize the files ;;; generated by this compiler: ;;; ;;; 0 string ;ELC GNU Emacs Lisp compiled file, @@ -210,17 +212,16 @@ be hard-coded into bytecomp when it compiles itself. If the compiler itself is compiled with optimization, this causes a speedup.") - (cond (byte-compile-single-version - (defmacro byte-compile-single-version () t) - (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond)))) - (t - (defmacro byte-compile-single-version () nil) - (defmacro byte-compile-version-cond (cond) cond))) + (cond + (byte-compile-single-version + (defmacro byte-compile-single-version () t) + (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond)))) + (t + (defmacro byte-compile-single-version () nil) + (defmacro byte-compile-version-cond (cond) cond))) ) -(defvar emacs-lisp-file-regexp (if (eq system-type 'vax-vms) - (purecopy "\\.EL\\(;[0-9]+\\)?$") - (purecopy "\\.el$")) +(defvar emacs-lisp-file-regexp (purecopy "\\.el$") "*Regexp which matches Emacs Lisp source files. You may want to redefine `byte-compile-dest-file' if you change this.") @@ -234,18 +235,16 @@ (funcall handler 'byte-compiler-base-file-name filename) filename))) -(or (fboundp 'byte-compile-dest-file) - ;; The user may want to redefine this along with emacs-lisp-file-regexp, - ;; so only define it if it is undefined. - (defun byte-compile-dest-file (filename) - "Convert an Emacs Lisp source file name to a compiled file name." - (setq filename (byte-compiler-base-file-name filename)) - (setq filename (file-name-sans-versions filename)) - (cond ((eq system-type 'vax-vms) - (concat (substring filename 0 (string-match ";" filename)) "c")) - ((string-match emacs-lisp-file-regexp filename) - (concat (substring filename 0 (match-beginning 0)) ".elc")) - (t (concat filename ".elc"))))) +(unless (fboundp 'byte-compile-dest-file) + ;; The user may want to redefine this along with emacs-lisp-file-regexp, + ;; so only define it if it is undefined. + (defun byte-compile-dest-file (filename) + "Convert an Emacs Lisp source file name to a compiled file name." + (setq filename (byte-compiler-base-file-name filename)) + (setq filename (file-name-sans-versions filename)) + (if (string-match emacs-lisp-file-regexp filename) + (concat (substring filename 0 (match-beginning 0)) ".elc") + (concat filename ".elc")))) ;; This can be the 'byte-compile property of any symbol. (autoload 'byte-compile-inline-expand "byte-optimize") @@ -260,7 +259,7 @@ ;; disassembler. The disassembler just requires 'byte-compile, but ;; that doesn't define this function, so this seems to be a reasonable ;; thing to do. -(autoload 'byte-decompile-bytecode "byte-opt") +(autoload 'byte-decompile-bytecode "byte-optimize") (defvar byte-compile-verbose (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) @@ -350,7 +349,7 @@ ;; byte-compile-warning-types in FSF. (defvar byte-compile-default-warnings - '(redefine callargs free-vars unresolved unused-vars obsolete) + '(redefine callargs subr-callargs free-vars unresolved unused-vars obsolete) "*The warnings used when byte-compile-warnings is t.") (defvar byte-compile-warnings t @@ -361,6 +360,7 @@ unused-vars references to non-global variables bound but not referenced. unresolved calls to unknown functions. callargs lambda calls with args that don't match the definition. + subr-callargs calls to subrs with args that don't match the definition. redefine function cell redefined from a macro to a lambda or vice versa, or redefined to take a different number of arguments. obsolete use of an obsolete function or variable. @@ -373,7 +373,7 @@ (defvar byte-compile-generate-call-tree nil "*Non-nil means collect call-graph information when compiling. -This records functions were called and from where. +This records functions that were called and from where. If the value is t, compilation displays the call graph when it finishes. If the value is neither t nor nil, compilation asks you whether to display the graph. @@ -432,6 +432,7 @@ (defvar byte-compile-free-references) (defvar byte-compile-free-assignments) +(defvar debug-issue-ebola-notices) (defvar byte-compiler-error-flag) @@ -620,7 +621,7 @@ "to examine top-of-stack, jump and don't pop it if it's nil, otherwise pop it") (byte-defop 134 -1 byte-goto-if-not-nil-else-pop - "to examine top-of-stack, jump and don't pop it if it's non nil, + "to examine top-of-stack, jump and don't pop it if it's non-nil, otherwise pop it") (byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'") @@ -770,13 +771,13 @@ (error "Non-symbolic opcode `%s'" op)) ((eq op 'TAG) (setcar off pc) - (setq patchlist (cons off patchlist))) + (push off patchlist)) ((memq op byte-goto-ops) (setq pc (+ pc 3)) (setq bytes (cons (cons pc (cdr off)) (cons nil (cons (symbol-value op) bytes)))) - (setq patchlist (cons bytes patchlist))) + (push bytes patchlist)) (t (setq bytes (cond ((cond ((consp off) @@ -859,81 +860,64 @@ (defvar byte-compile-dest-file nil) (defmacro byte-compile-log (format-string &rest args) - (list 'and - 'byte-optimize - '(memq byte-optimize-log '(t source)) - (list 'let '((print-escape-newlines t) - (print-level 4) - (print-length 4)) - (list 'byte-compile-log-1 - (cons 'format - (cons format-string - (mapcar - '(lambda (x) - (if (symbolp x) (list 'prin1-to-string x) x)) - args))))))) - -(defconst byte-compile-last-warned-form nil) + `(when (and byte-optimize (memq byte-optimize-log '(t source))) + (let ((print-escape-newlines t) + (print-level 4) + (print-length 4)) + (byte-compile-log-1 (format ,format-string ,@args))))) + +(defconst byte-compile-last-warned-form 'nothing) ;; Log a message STRING in *Compile-Log*. ;; Also log the current function and file if not already done. (defun byte-compile-log-1 (string &optional fill) - (let ((this-form (or byte-compile-current-form "toplevel forms"))) - (cond - (noninteractive - (if (or byte-compile-current-file - (and byte-compile-last-warned-form - (not (eq this-form byte-compile-last-warned-form)))) - (message - (format "While compiling %s%s:" - this-form - (if byte-compile-current-file - (if (stringp byte-compile-current-file) - (concat " in file " byte-compile-current-file) - (concat " in buffer " - (buffer-name byte-compile-current-file))) - "")))) - (message " %s" string)) - (t - (save-excursion - (set-buffer (get-buffer-create "*Compile-Log*")) + (let* ((this-form (or byte-compile-current-form "toplevel forms")) + (while-compiling-msg + (when (or byte-compile-current-file + (not (eq this-form byte-compile-last-warned-form))) + (format + "While compiling %s%s:" + this-form + (cond + ((stringp byte-compile-current-file) + (concat " in file " byte-compile-current-file)) + ((bufferp byte-compile-current-file) + (concat " in buffer " + (buffer-name byte-compile-current-file))) + ("")))))) + (if noninteractive + (progn + (when while-compiling-msg (message "%s" while-compiling-msg)) + (message " %s" string)) + (with-current-buffer (get-buffer-create "*Compile-Log*") (goto-char (point-max)) - (cond ((or byte-compile-current-file - (and byte-compile-last-warned-form - (not (eq this-form byte-compile-last-warned-form)))) - (if byte-compile-current-file - (insert "\n\^L\n" (current-time-string) "\n")) - (insert "While compiling " - (if (stringp this-form) this-form - (format "%s" this-form))) - (if byte-compile-current-file - (if (stringp byte-compile-current-file) - (insert " in file " byte-compile-current-file) - (insert " in buffer " - (buffer-name byte-compile-current-file)))) - (insert ":\n"))) + (when byte-compile-current-file + (when (> (point-max) (point-min)) + (insert "\n\^L\n")) + (insert (current-time-string) "\n")) + (when while-compiling-msg (insert while-compiling-msg "\n")) (insert " " string "\n") - (if (and fill (not (string-match "\n" string))) - (let ((fill-prefix " ") - (fill-column 78)) - (fill-paragraph nil))) - ))) - (setq byte-compile-current-file nil - byte-compile-last-warned-form this-form))) + (when (and fill (not (string-match "\n" string))) + (let ((fill-prefix " ") + (fill-column 78)) + (fill-paragraph nil))))) + (setq byte-compile-current-file nil) + (setq byte-compile-last-warned-form this-form))) ;; Log the start of a file in *Compile-Log*, and mark it as done. ;; But do nothing in batch mode. (defun byte-compile-log-file () - (and byte-compile-current-file (not noninteractive) - (save-excursion - (set-buffer (get-buffer-create "*Compile-Log*")) - (goto-char (point-max)) - (insert "\n\^L\nCompiling " - (if (stringp byte-compile-current-file) - (concat "file " byte-compile-current-file) - (concat "buffer " (buffer-name byte-compile-current-file))) - " at " (current-time-string) "\n") - (setq byte-compile-current-file nil)))) + (when (and byte-compile-current-file (not noninteractive)) + (with-current-buffer (get-buffer-create "*Compile-Log*") + (when (> (point-max) (point-min)) + (goto-char (point-max)) + (insert "\n\^L\n")) + (insert "Compiling " + (if (stringp byte-compile-current-file) + (concat "file " byte-compile-current-file) + (concat "buffer " (buffer-name byte-compile-current-file))) + " at " (current-time-string) "\n") + (setq byte-compile-current-file nil)))) (defun byte-compile-warn (format &rest args) (setq format (apply 'format format args)) @@ -987,7 +971,7 @@ (verbose byte-compile-verbose (t nil) val) (new-bytecodes byte-compile-new-bytecodes (t nil) val) (warnings byte-compile-warnings - ((callargs redefine free-vars unused-vars unresolved)) + ((callargs subr-callargs redefine free-vars unused-vars unresolved)) val))) ;; XEmacs addition @@ -1225,7 +1209,7 @@ nil) (defun byte-compile-defvar-p (var) - ;; Whether the byte compiler thinks that nonexical references to this + ;; Whether the byte compiler thinks that non-lexical references to this ;; variable are ok. (or (globally-boundp var) (let ((rest byte-compile-bound-variables)) @@ -1257,7 +1241,7 @@ ;; have (declare (ignore x)) yet; and second, inline ;; expansion produces forms like ;; ((lambda (arg) (byte-code "..." [arg])) x) - ;; which we can't (ok, well, don't) recognise as + ;; which we can't (ok, well, don't) recognize as ;; containing a reference to arg, so every inline ;; expansion would generate a warning. (If we had ;; `ignore' then inline expansion could emit an @@ -1275,12 +1259,14 @@ (setq unreferenced (cdr unreferenced))))) +(defmacro byte-compile-constant-symbol-p (symbol) + `(or (keywordp ,symbol) (memq ,symbol '(nil t)))) + (defmacro byte-compile-constp (form) ;; Returns non-nil if FORM is a constant. - (` (cond ((consp (, form)) (eq (car (, form)) 'quote)) - ((not (symbolp (, form)))) - ((keywordp (, form))) - ((memq (, form) '(nil t)))))) + `(cond ((consp ,form) (eq (car ,form) 'quote)) + ((symbolp ,form) (byte-compile-constant-symbol-p ,form)) + (t))) (defmacro byte-compile-close-variables (&rest body) `(let @@ -1313,6 +1299,9 @@ byte-compile-default-warnings byte-compile-warnings)) (byte-compile-file-domain nil) + + ;; We reserve the right to compare ANY objects for equality. + (debug-issue-ebola-notices -42) ) (prog1 (progn ,@body) @@ -1321,46 +1310,49 @@ (byte-compile-warn-about-unused-variables))))) -(defvar byte-compile-warnings-point-max nil) (defmacro displaying-byte-compile-warnings (&rest body) - `(let ((byte-compile-warnings-point-max byte-compile-warnings-point-max)) - ;; Log the file name. + `(let* ((byte-compile-log-buffer (get-buffer-create "*Compile-Log*")) + (byte-compile-point-max-prev (point-max byte-compile-log-buffer))) + ;; Log the file name or buffer name. (byte-compile-log-file) ;; Record how much is logged now. ;; We will display the log buffer if anything more is logged ;; before the end of BODY. - (or byte-compile-warnings-point-max - (save-excursion - (set-buffer (get-buffer-create "*Compile-Log*")) - (setq byte-compile-warnings-point-max (point-max)))) - (unwind-protect - (condition-case error-info - (progn ,@body) - (error - (byte-compile-report-error error-info))) - (save-excursion - ;; If there were compilation warnings, display them. - (set-buffer "*Compile-Log*") - (if (= byte-compile-warnings-point-max (point-max)) - nil - (if temp-buffer-show-function - (let ((show-buffer (get-buffer-create "*Compile-Log-Show*"))) - (save-excursion - (set-buffer show-buffer) - (setq buffer-read-only nil) - (erase-buffer)) - (copy-to-buffer show-buffer - (save-excursion - (goto-char byte-compile-warnings-point-max) - (forward-line -1) - (point)) - (point-max)) - (funcall temp-buffer-show-function show-buffer)) - (select-window - (prog1 (selected-window) - (select-window (display-buffer (current-buffer))) - (goto-char byte-compile-warnings-point-max) - (recenter 1))))))))) + (defvar byte-compile-warnings-beginning) + (let ((byte-compile-warnings-beginning + (if (boundp 'byte-compile-warnings-beginning) + byte-compile-warnings-beginning + (point-max byte-compile-log-buffer)))) + + (unwind-protect + (condition-case error-info + (progn ,@body) + (error + (byte-compile-report-error error-info))) + + ;; Always set point in log to start of interesting output. + (with-current-buffer byte-compile-log-buffer + (let ((show-begin + (progn (goto-char byte-compile-point-max-prev) + (skip-chars-forward "\^L\n") + (point)))) + ;; If there were compilation warnings, display them. + (if temp-buffer-show-function + (let ((show-buffer (get-buffer-create "*Compile-Log-Show*"))) + ;; Always clean show-buffer, even when not displaying it, + ;; so that misleading previous messages aren't left around. + (with-current-buffer show-buffer + (setq buffer-read-only nil) + (erase-buffer)) + (copy-to-buffer show-buffer show-begin (point-max)) + (when (< byte-compile-warnings-beginning (point-max)) + (funcall temp-buffer-show-function show-buffer))) + (when (< byte-compile-warnings-beginning (point-max)) + (select-window + (prog1 (selected-window) + (select-window (display-buffer (current-buffer))) + (goto-char show-begin) + (recenter 1))))))))))) ;;;###autoload @@ -1466,8 +1458,6 @@ (y-or-n-p (concat "Compile " filename "? ")))))) (byte-compile-file filename)))) -(defvar kanji-flag nil) - ;;;###autoload (defun byte-compile-file (filename &optional load) "Compile a file of Lisp code named FILENAME into a file of byte code. @@ -1503,7 +1493,6 @@ (message "Compiling %s..." filename)) (let (;;(byte-compile-current-file (file-name-nondirectory filename)) (byte-compile-current-file filename) - (debug-issue-ebola-notices 0) ; Hack -slb target-file input-buffer output-buffer byte-compile-dest-file) (setq target-file (byte-compile-dest-file filename)) @@ -1534,28 +1523,26 @@ (set-buffer output-buffer) (goto-char (point-max)) (insert "\n") ; aaah, unix. - (let ((vms-stmlf-recfm t)) - (setq target-file (byte-compile-dest-file filename)) - (or byte-compile-overwrite-file - (condition-case () - (delete-file target-file) - (error nil))) - (if (file-writable-p target-file) - (let ((kanji-flag nil)) ; for nemacs, from Nakagawa Takayuki - (if (or (eq system-type 'ms-dos) (eq system-type 'windows-nt)) - (setq buffer-file-type t)) - (write-region 1 (point-max) target-file)) - ;; This is just to give a better error message than write-region - (signal 'file-error - (list "Opening output file" - (if (file-exists-p target-file) - "cannot overwrite file" - "directory not writable or nonexistent") - target-file))) - (or byte-compile-overwrite-file - (condition-case () - (set-file-modes target-file (file-modes filename)) - (error nil)))) + (setq target-file (byte-compile-dest-file filename)) + (unless byte-compile-overwrite-file + (ignore-file-errors (delete-file target-file))) + (if (file-writable-p target-file) + (progn + (when (memq system-type '(ms-dos windows-nt)) + (defvar buffer-file-type) + (setq buffer-file-type t)) + (write-region 1 (point-max) target-file)) + ;; This is just to give a better error message than write-region + (signal 'file-error + (list "Opening output file" + (if (file-exists-p target-file) + "cannot overwrite file" + "directory not writable or nonexistent") + target-file))) + (or byte-compile-overwrite-file + (condition-case () + (set-file-modes target-file (file-modes filename)) + (error nil))) (kill-buffer (current-buffer))) (if (and byte-compile-generate-call-tree (or (eq t byte-compile-generate-call-tree) @@ -1664,7 +1651,7 @@ ;; Compile the forms from the input buffer. (while (progn - (while (progn (skip-chars-forward " \t\n\^l") + (while (progn (skip-chars-forward " \t\n\^L") (looking-at ";")) (forward-line 1)) (not (eobp))) @@ -1767,25 +1754,26 @@ ;; extended characters are output properly and distinguished properly. ;; Otherwise, use `no-conversion' for maximum portability with non-Mule ;; Emacsen. - (if (featurep 'mule) - (if (save-excursion - (set-buffer byte-compile-inbuffer) - (goto-char (point-min)) - ;; mrb- There must be a better way than skip-chars-forward - (skip-chars-forward (concat (char-to-string 0) "-" - (char-to-string 255))) - (eq (point) (point-max))) - (setq buffer-file-coding-system 'no-conversion) - (insert "(require 'mule)\n;;;###coding system: escape-quoted\n") - (setq buffer-file-coding-system 'escape-quoted) - ;; Lazy loading not yet implemented for MULE files - ;; mrb - Fix this someday. - (save-excursion + (when (featurep 'mule) + (defvar buffer-file-coding-system) + (if (save-excursion (set-buffer byte-compile-inbuffer) - (setq byte-compile-dynamic nil - byte-compile-dynamic-docstrings nil)) - ;;(external-debugging-output (prin1-to-string (buffer-local-variables)))) - )) + (goto-char (point-min)) + ;; mrb- There must be a better way than skip-chars-forward + (skip-chars-forward (concat (char-to-string 0) "-" + (char-to-string 255))) + (eq (point) (point-max))) + (setq buffer-file-coding-system 'no-conversion) + (insert "(require 'mule)\n;;;###coding system: escape-quoted\n") + (setq buffer-file-coding-system 'escape-quoted) + ;; #### Lazy loading not yet implemented for MULE files + ;; mrb - Fix this someday. + (save-excursion + (set-buffer byte-compile-inbuffer) + (setq byte-compile-dynamic nil + byte-compile-dynamic-docstrings nil)) + ;;(external-debugging-output (prin1-to-string (buffer-local-variables)))) + )) ) @@ -1904,8 +1892,8 @@ (nthcdr 300 byte-compile-output) (byte-compile-flush-pending)) (funcall handler form) - (if for-effect - (byte-compile-discard))) + (when for-effect + (byte-compile-discard))) (byte-compile-form form t)) nil) @@ -1939,7 +1927,7 @@ (byte-compile-file-form form))))) ;; Functions and variables with doc strings must be output separately, -;; so make-docfile can recognise them. Most other things can be output +;; so make-docfile can recognize them. Most other things can be output ;; as byte-code. (put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst) @@ -2106,32 +2094,32 @@ (cons (list name nil nil) byte-compile-call-tree)))) (setq byte-compile-current-form name) ; for warnings - (if (memq 'redefine byte-compile-warnings) - (byte-compile-arglist-warn form macrop)) - (if byte-compile-verbose - (message "Compiling %s... (%s)" - ;; #### filename used free - (if filename (file-name-nondirectory filename) "") - (nth 1 form))) + (when (memq 'redefine byte-compile-warnings) + (byte-compile-arglist-warn form macrop)) + (defvar filename) ; #### filename used free + (when byte-compile-verbose + (message "Compiling %s... (%s)" + (if filename (file-name-nondirectory filename) "") + (nth 1 form))) (cond (that-one - (if (and (memq 'redefine byte-compile-warnings) - ;; hack hack: don't warn when compiling the stubs in - ;; bytecomp-runtime... - (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))) + (when (and (memq 'redefine byte-compile-warnings) + ;; hack hack: don't warn when compiling the stubs in + ;; bytecomp-runtime... + (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 - (if (and (memq 'redefine byte-compile-warnings) - ;; hack: don't warn when compiling the magic internal - ;; byte-compiler macros in bytecomp-runtime.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)))) + (when (and (memq 'redefine byte-compile-warnings) + ;; hack: don't warn when compiling the magic internal + ;; byte-compiler macros in bytecomp-runtime.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) (or (subrp (symbol-function name)) (eq (car-safe (symbol-function name)) @@ -2145,8 +2133,7 @@ (if macrop "macro" "function"))) ;; shadow existing definition (set this-kind - (cons (cons name nil) (symbol-value this-kind)))) - ) + (cons (cons name nil) (symbol-value this-kind))))) (let ((body (nthcdr 3 form))) (if (and (stringp (car body)) (symbolp (car-safe (cdr-safe body))) @@ -2345,11 +2332,11 @@ (let* ((interactive (assq 'interactive (cdr (cdr fun))))) (nconc (list 'make-byte-code (list 'quote (nth 1 fun)) ;arglist - (nth 1 tmp) ;bytes - (nth 2 tmp) ;consts - (nth 3 tmp)) ;depth + (nth 1 tmp) ;instructions + (nth 2 tmp) ;constants + (nth 3 tmp)) ;stack-depth (cond ((stringp (nth 2 fun)) - (list (nth 2 fun))) ;doc + (list (nth 2 fun))) ;docstring (interactive (list nil))) (cond (interactive @@ -2371,8 +2358,7 @@ (let* ((arglist (nth 1 fun)) (byte-compile-bound-variables (let ((new-bindings - (mapcar (function (lambda (x) - (cons x byte-compile-arglist-bit))) + (mapcar #'(lambda (x) (cons x byte-compile-arglist-bit)) (and (memq 'free-vars byte-compile-warnings) (delq '&rest (delq '&optional (copy-sequence arglist))))))) @@ -2383,18 +2369,16 @@ (prog1 (car body) (setq body (cdr body))))) (int (assq 'interactive body))) - (let ((rest arglist)) - (while rest - (cond ((not (symbolp (car rest))) - (byte-compile-warn "non-symbol in arglist: %s" - (prin1-to-string (car rest)))) - ((memq (car rest) '(t nil)) - (byte-compile-warn "constant in arglist: %s" (car rest))) - ((and (char= ?\& (aref (symbol-name (car rest)) 0)) - (not (memq (car rest) '(&optional &rest)))) - (byte-compile-warn "unrecognised `&' keyword in arglist: %s" - (car rest)))) - (setq rest (cdr rest)))) + (dolist (arg arglist) + (cond ((not (symbolp arg)) + (byte-compile-warn "non-symbol in arglist: %S" arg)) + ((byte-compile-constant-symbol-p arg) + (byte-compile-warn "constant symbol in arglist: %s" arg)) + ((and (char= ?\& (aref (symbol-name arg) 0)) + (not (eq arg '&optional)) + (not (eq arg '&rest))) + (byte-compile-warn "unrecognized `&' keyword in arglist: %s" + arg)))) (cond (int ;; Skip (interactive) if it is in front (the most usual location). (if (eq int (car body)) @@ -2555,8 +2539,7 @@ (if (if (eq (car (car rest)) 'byte-constant) (or (consp tmp) (and (symbolp tmp) - (not (keywordp tmp)) - (not (memq tmp '(nil t)))))) + (not (byte-compile-constant-symbol-p tmp))))) (if maycall (setq body (cons (list 'quote tmp) body))) (setq body (cons tmp body)))) @@ -2606,7 +2589,7 @@ ;; This is the recursive entry point for compiling each subform of an ;; expression. ;; If for-effect is non-nil, byte-compile-form will output a byte-discard -;; before terminating (ie no value will be left on the stack). +;; before terminating (ie. no value will be left on the stack). ;; A byte-compile handler may, when for-effect is non-nil, choose output code ;; which does not leave a value on the stack, and then set for-effect to nil ;; (to prevent byte-compile-form from outputting the byte-discard). @@ -2617,8 +2600,8 @@ (defun byte-compile-form (form &optional for-effect) (setq form (macroexpand form byte-compile-macro-environment)) (cond ((not (consp form)) - ;; XEmacs addition: keywordp - (cond ((or (not (symbolp form)) (keywordp form) (memq form '(nil t))) + (cond ((or (not (symbolp form)) + (byte-compile-constant-symbol-p form)) (byte-compile-constant form)) ((and for-effect byte-compile-delete-errors) (setq for-effect nil)) @@ -2644,8 +2627,8 @@ (byte-compile-form form for-effect) (setq for-effect nil)) ((byte-compile-normal-call form))) - (if for-effect - (byte-compile-discard))) + (when for-effect + (byte-compile-discard))) (defun byte-compile-normal-call (form) (if byte-compile-generate-call-tree @@ -2658,12 +2641,14 @@ (or (fboundp 'globally-boundp) (fset 'globally-boundp 'boundp)) (defun byte-compile-variable-ref (base-op var &optional varbind-flags) - (if (or (not (symbolp var)) (keywordp var) (memq var '(nil t))) - (byte-compile-warn (if (eq base-op 'byte-varbind) - "Attempt to let-bind %s %s" - "Variable reference to %s %s") - (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var)) + (if (or (not (symbolp var)) (byte-compile-constant-symbol-p var)) + (byte-compile-warn + (case base-op + (byte-varref "Variable reference to %s %s") + (byte-varset "Attempt to set %s %s") + (byte-varbind "Attempt to let-bind %s %s")) + (if (symbolp var) "constant symbol" "non-symbol") + var) (if (and (get var 'byte-obsolete-variable) (memq 'obsolete byte-compile-warnings)) (let ((ob (get var 'byte-obsolete-variable))) @@ -2709,11 +2694,11 @@ (byte-compile-out base-op tmp))) (defmacro byte-compile-get-constant (const) - (` (or (if (stringp (, const)) - (assoc (, const) byte-compile-constants) - (assq (, const) byte-compile-constants)) - (car (setq byte-compile-constants - (cons (list (, const)) byte-compile-constants)))))) + `(or (if (stringp ,const) + (assoc ,const byte-compile-constants) + (assq ,const byte-compile-constants)) + (car (setq byte-compile-constants + (cons (list ,const) byte-compile-constants))))) ;; Use this when the value of a form is a constant. This obeys for-effect. (defun byte-compile-constant (const) @@ -2894,12 +2879,6 @@ (byte-defop-compiler20 old-memq 2) (byte-defop-compiler cons 2) (byte-defop-compiler aref 2) -(byte-defop-compiler (= byte-eqlsign) byte-compile-one-or-more-args) -(byte-defop-compiler (< byte-lss) byte-compile-one-or-more-args) -(byte-defop-compiler (> byte-gtr) byte-compile-one-or-more-args) -(byte-defop-compiler (<= byte-leq) byte-compile-one-or-more-args) -(byte-defop-compiler (>= byte-geq) byte-compile-one-or-more-args) -(byte-defop-compiler /= byte-compile-/=) (byte-defop-compiler get 2+1) (byte-defop-compiler nth 2) (byte-defop-compiler substring 2-3) @@ -2922,9 +2901,6 @@ (byte-defop-compiler (rplacd byte-setcdr) 2) (byte-defop-compiler setcar 2) (byte-defop-compiler setcdr 2) -;; buffer-substring now has its own function. This used to be -;; 2+1, but now all args are optional. -(byte-defop-compiler buffer-substring) (byte-defop-compiler delete-region 2+1) (byte-defop-compiler narrow-to-region 2+1) (byte-defop-compiler (% byte-rem) 2) @@ -2954,55 +2930,56 @@ (defun byte-compile-subr-wrong-args (form n) - (byte-compile-warn "%s called with %d arg%s, but requires %s" - (car form) (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s") n) + (when (memq 'subr-callargs byte-compile-warnings) + (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)) (defun byte-compile-no-args (form) - (if (not (= (length form) 1)) - (byte-compile-subr-wrong-args form "none") - (byte-compile-out (get (car form) 'byte-opcode) 0))) + (case (length (cdr form)) + (0 (byte-compile-out (get (car form) 'byte-opcode) 0)) + (t (byte-compile-subr-wrong-args form "none")))) (defun byte-compile-one-arg (form) - (if (not (= (length form) 2)) - (byte-compile-subr-wrong-args form 1) - (byte-compile-form (car (cdr form))) ;; Push the argument - (byte-compile-out (get (car form) 'byte-opcode) 0))) + (case (length (cdr form)) + (1 (byte-compile-form (car (cdr form))) ;; Push the argument + (byte-compile-out (get (car form) 'byte-opcode) 0)) + (t (byte-compile-subr-wrong-args form 1)))) (defun byte-compile-two-args (form) - (if (not (= (length form) 3)) - (byte-compile-subr-wrong-args form 2) - (byte-compile-form (car (cdr form))) ;; Push the arguments - (byte-compile-form (nth 2 form)) - (byte-compile-out (get (car form) 'byte-opcode) 0))) + (case (length (cdr form)) + (2 (byte-compile-form (nth 1 form)) ;; Push the arguments + (byte-compile-form (nth 2 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0)) + (t (byte-compile-subr-wrong-args form 2)))) (defun byte-compile-three-args (form) - (if (not (= (length form) 4)) - (byte-compile-subr-wrong-args form 3) - (byte-compile-form (car (cdr form))) ;; Push the arguments - (byte-compile-form (nth 2 form)) - (byte-compile-form (nth 3 form)) - (byte-compile-out (get (car form) 'byte-opcode) 0))) + (case (length (cdr form)) + (3 (byte-compile-form (nth 1 form)) ;; Push the arguments + (byte-compile-form (nth 2 form)) + (byte-compile-form (nth 3 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0)) + (t (byte-compile-subr-wrong-args form 3)))) (defun byte-compile-zero-or-one-arg (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-one-arg (append form '(nil)))) - ((= len 2) (byte-compile-one-arg form)) - (t (byte-compile-subr-wrong-args form "0-1"))))) + (case (length (cdr form)) + (0 (byte-compile-one-arg (append form '(nil)))) + (1 (byte-compile-one-arg form)) + (t (byte-compile-subr-wrong-args form "0-1")))) (defun byte-compile-one-or-two-args (form) - (let ((len (length form))) - (cond ((= len 2) (byte-compile-two-args (append form '(nil)))) - ((= len 3) (byte-compile-two-args form)) - (t (byte-compile-subr-wrong-args form "1-2"))))) + (case (length (cdr form)) + (1 (byte-compile-two-args (append form '(nil)))) + (2 (byte-compile-two-args form)) + (t (byte-compile-subr-wrong-args form "1-2")))) (defun byte-compile-two-or-three-args (form) - (let ((len (length form))) - (cond ((= len 3) (byte-compile-three-args (append form '(nil)))) - ((= len 4) (byte-compile-three-args form)) - (t (byte-compile-subr-wrong-args form "2-3"))))) + (case (length (cdr form)) + (2 (byte-compile-three-args (append form '(nil)))) + (3 (byte-compile-three-args form)) + (t (byte-compile-subr-wrong-args form "2-3")))) ;; from Ben Wing <ben@xemacs.org>: some inlined functions have extra ;; optional args added to them in XEmacs 19.12. Changing the byte @@ -3013,55 +2990,55 @@ ;; `byte-compile-subr-wrong-args' also converts the call to non-inlined. (defun byte-compile-no-args-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-no-args form)) - ((= len 2) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "0-1"))))) + (case (length (cdr form)) + (0 (byte-compile-no-args form)) + (1 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "0-1")))) (defun byte-compile-one-arg-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 2) (byte-compile-one-arg form)) - ((= len 3) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "1-2"))))) + (case (length (cdr form)) + (1 (byte-compile-one-arg form)) + (2 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "1-2")))) (defun byte-compile-two-args-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 3) (byte-compile-two-args form)) - ((= len 4) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "2-3"))))) + (case (length (cdr form)) + (2 (byte-compile-two-args form)) + (3 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "2-3")))) (defun byte-compile-zero-or-one-arg-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-one-arg (append form '(nil)))) - ((= len 2) (byte-compile-one-arg form)) - ((= len 3) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "0-2"))))) + (case (length (cdr form)) + (0 (byte-compile-one-arg (append form '(nil)))) + (1 (byte-compile-one-arg form)) + (2 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "0-2")))) (defun byte-compile-one-or-two-args-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 2) (byte-compile-two-args (append form '(nil)))) - ((= len 3) (byte-compile-two-args form)) - ((= len 4) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "1-3"))))) + (case (length (cdr form)) + (1 (byte-compile-two-args (append form '(nil)))) + (2 (byte-compile-two-args form)) + (3 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "1-3")))) (defun byte-compile-two-or-three-args-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 3) (byte-compile-three-args (append form '(nil)))) - ((= len 4) (byte-compile-three-args form)) - ((= len 5) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "2-4"))))) + (case (length (cdr form)) + (2 (byte-compile-three-args (append form '(nil)))) + (3 (byte-compile-three-args form)) + (4 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "2-4")))) (defun byte-compile-no-args-with-two-extra (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-no-args form)) - ((or (= len 2) (= len 3)) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "0-2"))))) + (case (length (cdr form)) + (0 (byte-compile-no-args form)) + ((1 2) (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "0-2")))) (defun byte-compile-one-arg-with-two-extra (form) - (let ((len (length form))) - (cond ((= len 2) (byte-compile-one-arg form)) - ((or (= len 3) (= len 4)) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "1-3"))))) + (case (length (cdr form)) + (1 (byte-compile-one-arg form)) + ((2 3) (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "1-3")))) ;; XEmacs: used for functions that have a different opcode in v19 than v20. ;; this includes `eq', `equal', and other old-ified functions. @@ -3080,21 +3057,33 @@ (defun byte-compile-discard () (byte-compile-out 'byte-discard 0)) +;; Compile a function that accepts one or more args and is right-associative. +;; We do it by left-associativity so that the operations +;; are done in the same order as in interpreted code. +;(defun byte-compile-associative (form) +; (if (cdr form) +; (let ((opcode (get (car form) 'byte-opcode)) +; (args (copy-sequence (cdr form)))) +; (byte-compile-form (car args)) +; (setq args (cdr args)) +; (while args +; (byte-compile-form (car args)) +; (byte-compile-out opcode 0) +; (setq args (cdr args)))) +; (byte-compile-constant (eval form)))) ;; Compile a function that accepts one or more args and is right-associative. ;; We do it by left-associativity so that the operations ;; are done in the same order as in interpreted code. (defun byte-compile-associative (form) - (if (cdr form) - (let ((opcode (get (car form) 'byte-opcode)) - (args (copy-sequence (cdr form)))) - (byte-compile-form (car args)) - (setq args (cdr args)) - (while args - (byte-compile-form (car args)) - (byte-compile-out opcode 0) - (setq args (cdr args)))) - (byte-compile-constant (eval form)))) + (let ((args (cdr form)) + (opcode (get (car form) 'byte-opcode))) + (case (length args) + (0 (byte-compile-constant (eval form))) + (t (byte-compile-form (car args)) + (dolist (arg (cdr args)) + (byte-compile-form arg) + (byte-compile-out opcode 0)))))) ;; more complicated compiler macros @@ -3109,20 +3098,32 @@ (byte-defop-compiler nconc) (byte-defop-compiler-1 beginning-of-line) -(defun byte-compile-one-or-more-args (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-subr-wrong-args form "1 or more")) - ((= len 2) (byte-compile-constant t)) - ((= len 3) (byte-compile-two-args form)) - (t (byte-compile-normal-call form))))) +(byte-defop-compiler (= byte-eqlsign) byte-compile-arithcompare) +(byte-defop-compiler (< byte-lss) byte-compile-arithcompare) +(byte-defop-compiler (> byte-gtr) byte-compile-arithcompare) +(byte-defop-compiler (<= byte-leq) byte-compile-arithcompare) +(byte-defop-compiler (>= byte-geq) byte-compile-arithcompare) + +(defun byte-compile-arithcompare (form) + (case (length (cdr form)) + (0 (byte-compile-subr-wrong-args form "1 or more")) + (1 (byte-compile-constant t)) + (2 (byte-compile-two-args form)) + (t (byte-compile-normal-call form)))) + +(byte-defop-compiler /= byte-compile-/=) (defun byte-compile-/= (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-subr-wrong-args form "1 or more")) - ((= len 2) (byte-compile-constant t)) - ;; optimize (/= X Y) to (not (= X Y)) - ((= len 3) (byte-compile-form-do-effect `(not (= ,@(cdr form))))) - (t (byte-compile-normal-call form))))) + (case (length (cdr form)) + (0 (byte-compile-subr-wrong-args form "1 or more")) + (1 (byte-compile-constant t)) + ;; optimize (/= X Y) to (not (= X Y)) + (2 (byte-compile-form-do-effect `(not (= ,@(cdr form))))) + (t (byte-compile-normal-call form)))) + +;; buffer-substring now has its own function. This used to be +;; 2+1, but now all args are optional. +(byte-defop-compiler buffer-substring) (defun byte-compile-buffer-substring (form) ;; buffer-substring used to take exactly two args, but now takes 0-3. @@ -3136,65 +3137,71 @@ (t (byte-compile-subr-wrong-args form "0-3")))) (defun byte-compile-list (form) - (let ((count (length (cdr form)))) - (cond ((= count 0) - (byte-compile-constant nil)) - ((< count 5) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out - (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0)) - ((< count 256) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out 'byte-listN count)) - (t (byte-compile-normal-call form))))) + (let* ((args (cdr form)) + (nargs (length args))) + (cond + ((= nargs 0) + (byte-compile-constant nil)) + ((< nargs 5) + (mapcar 'byte-compile-form args) + (byte-compile-out + (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- nargs)) + 0)) + ((< nargs 256) + (mapcar 'byte-compile-form args) + (byte-compile-out 'byte-listN nargs)) + (t (byte-compile-normal-call form))))) (defun byte-compile-concat (form) - (let ((count (length (cdr form)))) - (cond ((and (< 1 count) (< count 5)) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out - (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2)) - 0)) - ;; Concat of one arg is not a no-op if arg is not a string. - ((= count 0) - (byte-compile-form "")) - ((< count 256) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out 'byte-concatN count)) - ((byte-compile-normal-call form))))) + (let* ((args (cdr form)) + (nargs (length args))) + ;; Concat of one arg is not a no-op if arg is not a string. + (cond + ((memq nargs '(2 3 4)) + (mapcar 'byte-compile-form args) + (byte-compile-out + (aref [byte-concat2 byte-concat3 byte-concat4] (- nargs 2)) + 0)) + ((eq nargs 0) + (byte-compile-form "")) + ((< nargs 256) + (mapcar 'byte-compile-form args) + (byte-compile-out 'byte-concatN nargs)) + ((byte-compile-normal-call form))))) (defun byte-compile-minus (form) - (if (null (setq form (cdr form))) - (byte-compile-constant 0) - (byte-compile-form (car form)) - (if (cdr form) - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-diff 0)) - (byte-compile-out 'byte-negate 0)))) + (let ((args (cdr form))) + (case (length args) + (0 (byte-compile-subr-wrong-args form "1 or more")) + (1 (byte-compile-form (car args)) + (byte-compile-out 'byte-negate 0)) + (t (byte-compile-form (car args)) + (dolist (elt (cdr args)) + (byte-compile-form elt) + (byte-compile-out 'byte-diff 0)))))) (defun byte-compile-quo (form) - (let ((len (length form))) - (cond ((<= len 2) - (byte-compile-subr-wrong-args form "2 or more")) - (t - (byte-compile-form (car (setq form (cdr form)))) - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-quo 0)))))) + (let ((args (cdr form))) + (case (length args) + (0 (byte-compile-subr-wrong-args form "1 or more")) + (1 (byte-compile-constant 1) + (byte-compile-form (car args)) + (byte-compile-out 'byte-quo 0)) + (t (byte-compile-form (car args)) + (dolist (elt (cdr args)) + (byte-compile-form elt) + (byte-compile-out 'byte-quo 0)))))) (defun byte-compile-nconc (form) - (let ((len (length form))) - (cond ((= len 1) - (byte-compile-constant nil)) - ((= len 2) - ;; nconc of one arg is a noop, even if that arg isn't a list. - (byte-compile-form (nth 1 form))) - (t - (byte-compile-form (car (setq form (cdr form)))) - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-nconc 0)))))) + (let ((args (cdr form))) + (case (length args) + (0 (byte-compile-constant nil)) + ;; nconc of one arg is a noop, even if that arg isn't a list. + (1 (byte-compile-form (car args))) + (t (byte-compile-form (car args)) + (dolist (elt (cdr args)) + (byte-compile-form elt) + (byte-compile-out 'byte-nconc 0)))))) (defun byte-compile-fset (form) ;; warn about forms like (fset 'foo '(lambda () ...)) @@ -3203,19 +3210,18 @@ ;; I'm sick of getting mail asking me whether that warning is a problem. (let ((fn (nth 2 form)) body) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (setq fn (nth 1 fn))) 'lambda) - (not (eq (car-safe (cdr-safe (nth 1 form))) 'make-byte-code))) - (progn - (setq body (cdr (cdr fn))) - (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 + (when (and (eq (car-safe fn) 'quote) + (eq (car-safe (setq fn (nth 1 fn))) 'lambda) + (not (eq (car-safe (cdr-safe (nth 1 form))) 'make-byte-code))) + (setq body (cdr (cdr fn))) + (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."))))) + the syntax (function (lambda (...) ...)) instead.")))) (byte-compile-two-args form)) (defun byte-compile-funarg (form) @@ -3255,8 +3261,8 @@ (while (setq form (cdr form)) (byte-compile-form (car form)) (byte-compile-out 'byte-insert 0) - (if (cdr form) - (byte-compile-discard)))))) + (when (cdr form) + (byte-compile-discard)))))) ;; alas, the old (pre-19.12, and all existing versions of FSFmacs 19) ;; byte compiler will generate incorrect code for @@ -3290,76 +3296,82 @@ (byte-defop-compiler-1 quote-form) (defun byte-compile-setq (form) - (let ((args (cdr form))) - (if args - (while args - (byte-compile-form (car (cdr args))) - (or for-effect (cdr (cdr args)) + (let ((args (cdr form)) var val) + (if (null args) + ;; (setq), with no arguments. + (byte-compile-form nil for-effect) + (while args + (setq var (pop args)) + (if (null args) + ;; Odd number of args? Let `set' get the error. + (byte-compile-form `(set ',var) for-effect) + (setq val (pop args)) + (if (keywordp var) + ;; (setq :foo ':foo) compatibility kludge + (byte-compile-form `(set ',var ,val) (if args t for-effect)) + (byte-compile-form val) + (unless (or args for-effect) (byte-compile-out 'byte-dup 0)) - (byte-compile-variable-ref 'byte-varset (car args)) - (setq args (cdr (cdr args)))) - ;; (setq), with no arguments. - (byte-compile-form nil for-effect)) - (setq for-effect nil))) + (byte-compile-variable-ref 'byte-varset var)))))) + (setq for-effect nil)) (defun byte-compile-set (form) ;; Compile (set 'foo x) as (setq foo x) for trivially better code and so ;; that we get applicable warnings. Compile everything else (including ;; malformed calls) like a normal 2-arg byte-coded function. - (if (or (not (eq (car-safe (nth 1 form)) 'quote)) - (not (= (length form) 3)) - (not (= (length (nth 1 form)) 2))) - (byte-compile-two-args form) - (byte-compile-setq (list 'setq (nth 1 (nth 1 form)) (nth 2 form))))) + (let ((symform (nth 1 form)) + (valform (nth 2 form)) + sym) + (if (and (= (length form) 3) + (= (safe-length symform) 2) + (eq (car symform) 'quote) + (symbolp (setq sym (car (cdr symform)))) + (not (byte-compile-constant-symbol-p sym))) + (byte-compile-setq `(setq ,sym ,valform)) + (byte-compile-two-args form)))) (defun byte-compile-setq-default (form) - (let ((rest (cdr form))) - ;; emit multiple calls to set-default if necessary - (while rest - (byte-compile-form - (list 'set-default (list 'quote (car rest)) (car (cdr rest))) - (not (null (cdr (cdr rest))))) - (setq rest (cdr (cdr rest)))))) + (let ((args (cdr form))) + (if (null args) + ;; (setq-default), with no arguments. + (byte-compile-form nil for-effect) + ;; emit multiple calls to `set-default' if necessary + (while args + (byte-compile-form + ;; Odd number of args? Let `set-default' get the error. + `(set-default ',(pop args) ,@(if args (list (pop args)) nil)) + (if args t for-effect))))) + (setq for-effect nil)) + (defun byte-compile-set-default (form) - (let ((rest (cdr form))) - (if (cdr (cdr (cdr form))) - ;; emit multiple calls to set-default if necessary; all but last - ;; for-effect (this recurses.) - (while rest - (byte-compile-form - (list 'set-default (car rest) (car (cdr rest))) - (not (null (cdr rest)))) - (setq rest (cdr (cdr rest)))) - ;; else, this is the one-armed version - (let ((var (nth 1 form)) - ;;(val (nth 2 form)) - ) - ;; notice calls to set-default/setq-default for variables which - ;; have not been declared with defvar/defconst. - (if (and (memq 'free-vars byte-compile-warnings) - (or (null var) - (and (eq (car-safe var) 'quote) - (= 2 (length var))))) - (let ((sym (nth 1 var)) - cell) - (or (and sym (symbolp sym) (globally-boundp sym)) - (and (setq cell (assq sym byte-compile-bound-variables)) - (setcdr cell (logior (cdr cell) - byte-compile-assigned-bit))) - (memq sym byte-compile-free-assignments) - (if (or (not (symbolp sym)) (memq sym '(t nil))) - (progn - (byte-compile-warn - "Attempt to set-globally %s %s" - (if (symbolp sym) "constant" "nonvariable") - (prin1-to-string sym))) - (progn - (byte-compile-warn "assignment to free variable %s" sym) - (setq byte-compile-free-assignments - (cons sym byte-compile-free-assignments))))))) - ;; now emit a normal call to set-default (or possibly multiple calls) - (byte-compile-normal-call form))))) + (let* ((args (cdr form)) + (nargs (length args)) + (var (car args))) + (when (and (= (safe-length var) 2) + (eq (car var) 'quote)) + (let ((sym (nth 1 var))) + (cond + ((not (symbolp sym)) + (byte-compile-warn "Attempt to set-globally non-symbol %s" sym)) + ((byte-compile-constant-symbol-p sym) + (byte-compile-warn "Attempt to set-globally constant symbol %s" sym)) + ((let ((cell (assq sym byte-compile-bound-variables))) + (and cell + (setcdr cell (logior (cdr cell) byte-compile-assigned-bit)) + t))) + ;; notice calls to set-default/setq-default for variables which + ;; have not been declared with defvar/defconst. + ((globally-boundp sym)) ; OK + ((not (memq 'free-vars byte-compile-warnings))) ; warnings suppressed? + ((memq sym byte-compile-free-assignments)) ; already warned about sym + (t + (byte-compile-warn "assignment to free variable %s" sym) + (push sym byte-compile-free-assignments))))) + (if (= nargs 2) + ;; now emit a normal call to set-default + (byte-compile-normal-call form) + (byte-compile-subr-wrong-args form 2)))) (defun byte-compile-quote (form) @@ -3408,20 +3420,22 @@ (byte-compile-body-do-effect (cdr form))) (defun byte-compile-prog1 (form) - (byte-compile-form-do-effect (car (cdr form))) - (byte-compile-body (cdr (cdr form)) t)) + (setq form (cdr form)) + (byte-compile-form-do-effect (pop form)) + (byte-compile-body form t)) (defun byte-compile-prog2 (form) - (byte-compile-form (nth 1 form) t) - (byte-compile-form-do-effect (nth 2 form)) - (byte-compile-body (cdr (cdr (cdr form))) t)) + (setq form (cdr form)) + (byte-compile-form (pop form) t) + (byte-compile-form-do-effect (pop form)) + (byte-compile-body form t)) (defmacro byte-compile-goto-if (cond discard tag) - (` (byte-compile-goto - (if (, cond) - (if (, discard) 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop) - (if (, discard) 'byte-goto-if-nil 'byte-goto-if-nil-else-pop)) - (, tag)))) + `(byte-compile-goto + (if ,cond + (if ,discard 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop) + (if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop)) + ,tag)) (defun byte-compile-if (form) (byte-compile-form (car (cdr form))) @@ -3827,7 +3841,7 @@ (defun byte-compile-out-tag (tag) - (setq byte-compile-output (cons tag byte-compile-output)) + (push tag byte-compile-output) (if (cdr (cdr tag)) (progn ;; ## remove this someday @@ -3838,7 +3852,7 @@ (setcdr (cdr tag) byte-compile-depth))) (defun byte-compile-goto (opcode tag) - (setq byte-compile-output (cons (cons opcode tag) byte-compile-output)) + (push (cons opcode tag) byte-compile-output) (setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops) (1- byte-compile-depth) byte-compile-depth)) @@ -3846,20 +3860,21 @@ (1- byte-compile-depth)))) (defun byte-compile-out (opcode offset) - (setq byte-compile-output (cons (cons opcode offset) byte-compile-output)) - (cond ((eq opcode 'byte-call) - (setq byte-compile-depth (- byte-compile-depth offset))) - ((eq opcode 'byte-return) - ;; This is actually an unnecessary case, because there should be - ;; no more opcodes behind byte-return. - (setq byte-compile-depth nil)) - (t - (setq byte-compile-depth (+ byte-compile-depth - (or (aref byte-stack+-info - (symbol-value opcode)) - (- (1- offset)))) - byte-compile-maxdepth (max byte-compile-depth - byte-compile-maxdepth)))) + (push (cons opcode offset) byte-compile-output) + (case opcode + (byte-call + (setq byte-compile-depth (- byte-compile-depth offset))) + (byte-return + ;; This is actually an unnecessary case, because there should be + ;; no more opcodes behind byte-return. + (setq byte-compile-depth nil)) + (t + (setq byte-compile-depth (+ byte-compile-depth + (or (aref byte-stack+-info + (symbol-value opcode)) + (- (1- offset)))) + byte-compile-maxdepth (max byte-compile-depth + byte-compile-maxdepth)))) ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) ) @@ -3873,18 +3888,15 @@ (or (memq byte-compile-current-form (nth 1 entry)) ;callers (setcar (cdr entry) (cons byte-compile-current-form (nth 1 entry)))) - (setq byte-compile-call-tree - (cons (list (car form) (list byte-compile-current-form) nil) - byte-compile-call-tree))) + (push (list (car form) (list byte-compile-current-form) nil) + byte-compile-call-tree)) ;; annotate the current function (if (setq entry (assq byte-compile-current-form byte-compile-call-tree)) (or (memq (car form) (nth 2 entry)) ;called (setcar (cdr (cdr entry)) (cons (car form) (nth 2 entry)))) - (setq byte-compile-call-tree - (cons (list byte-compile-current-form nil (list (car form))) - byte-compile-call-tree))) - )) + (push (list byte-compile-current-form nil (list (car form))) + byte-compile-call-tree)))) ;; Renamed from byte-compile-report-call-tree ;; to avoid interfering with completion of byte-compile-file. @@ -3923,19 +3935,19 @@ (sort byte-compile-call-tree (cond ((eq byte-compile-call-tree-sort 'callers) - (function (lambda (x y) (< (length (nth 1 x)) - (length (nth 1 y)))))) + #'(lambda (x y) (< (length (nth 1 x)) + (length (nth 1 y))))) ((eq byte-compile-call-tree-sort 'calls) - (function (lambda (x y) (< (length (nth 2 x)) - (length (nth 2 y)))))) + #'(lambda (x y) (< (length (nth 2 x)) + (length (nth 2 y))))) ((eq byte-compile-call-tree-sort 'calls+callers) - (function (lambda (x y) (< (+ (length (nth 1 x)) - (length (nth 2 x))) - (+ (length (nth 1 y)) - (length (nth 2 y))))))) + #'(lambda (x y) (< (+ (length (nth 1 x)) + (length (nth 2 x))) + (+ (length (nth 1 y)) + (length (nth 2 y)))))) ((eq byte-compile-call-tree-sort 'name) - (function (lambda (x y) (string< (car x) - (car y))))) + #'(lambda (x y) (string< (car x) + (car y)))) (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" byte-compile-call-tree-sort)))))) @@ -4031,8 +4043,7 @@ (defvar command-line-args-left) ;Avoid 'free variable' warning (if (not noninteractive) (error "`batch-byte-compile' is to be used only with -batch")) - (let ((error nil) - (debug-issue-ebola-notices 0)) ; Hack -slb + (let ((error nil)) (while command-line-args-left (if (file-directory-p (expand-file-name (car command-line-args-left))) (let ((files (directory-files (car command-line-args-left))) @@ -4065,7 +4076,7 @@ (if (fboundp 'display-error) ; XEmacs 19.8+ (display-error err nil) (princ (or (get (car err) 'error-message) (car err))) - (mapcar '(lambda (x) (princ " ") (prin1 x)) (cdr err))) + (mapcar #'(lambda (x) (princ " ") (prin1 x)) (cdr err))) (princ "\n") nil))) @@ -4086,8 +4097,7 @@ (error "batch-byte-recompile-directory is to be used only with -batch")) (or command-line-args-left (setq command-line-args-left '("."))) - (let ((byte-recompile-directory-ignore-errors-p t) - (debug-issue-ebola-notices 0)) + (let ((byte-recompile-directory-ignore-errors-p t)) (while command-line-args-left (byte-recompile-directory (car command-line-args-left)) (setq command-line-args-left (cdr command-line-args-left)))) @@ -4140,10 +4150,10 @@ (assq 'byte-code (symbol-function 'byte-compile-form)) (let ((byte-optimize nil) ; do it fast (byte-compile-warnings nil)) - (mapcar '(lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) + (mapcar #'(lambda (x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x))) '(byte-compile-normal-call byte-compile-form byte-compile-body