;; 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.
;;; '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)
;;; 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,
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.")
(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")
;; 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))
;; 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
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.
(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.
(defvar byte-compile-free-references)
(defvar byte-compile-free-assignments)
+(defvar debug-issue-ebola-notices)
(defvar byte-compiler-error-flag)
"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'")
(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)
(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))
(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
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))
;; 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
(setq unreferenced (cdr unreferenced)))))
\f
+(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
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)
(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)))))))))))
\f
;;;###autoload
(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.
(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))
(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)
;; 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)))
;; 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))))
+ ))
)
(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)
(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)
(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))
(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)))
(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
(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)))))))
(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))
(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))))
;; 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).
(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))
(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
(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)))
(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)
(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)
(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)
\f
(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
;; `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.
(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))))))
\f
;; more complicated compiler macros
(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.
(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 () ...))
;; 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)
(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
(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)
(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)))
(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
(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))
(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"))
)
(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.
(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))))))
(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)))
(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)))
(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))))
(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
projects / chise / xemacs-chise.git.1 / blobdiff