comparison 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
comparison
equal deleted inserted replaced
379:76b7d63099ad 380:8626e4521993
7 ;; Hallvard Furuseth <hbf@ulrik.uio.no> 7 ;; Hallvard Furuseth <hbf@ulrik.uio.no>
8 ;; Keywords: internal 8 ;; Keywords: internal
9 9
10 ;; Subsequently modified by RMS and others. 10 ;; Subsequently modified by RMS and others.
11 11
12 (defconst byte-compile-version (purecopy "2.25 XEmacs; 22-Mar-96.")) 12 (defconst byte-compile-version (purecopy "2.26 XEmacs; 1998-10-07."))
13 13
14 ;; This file is part of XEmacs. 14 ;; This file is part of XEmacs.
15 15
16 ;; XEmacs is free software; you can redistribute it and/or modify it 16 ;; XEmacs is free software; you can redistribute it and/or modify it
17 ;; under the terms of the GNU General Public License as published by 17 ;; under the terms of the GNU General Public License as published by
99 ;;; 'unused-vars (non-global variables bound but 99 ;;; 'unused-vars (non-global variables bound but
100 ;;; not referenced) 100 ;;; not referenced)
101 ;;; 'unresolved (calls to unknown functions) 101 ;;; 'unresolved (calls to unknown functions)
102 ;;; 'callargs (lambda calls with args that don't 102 ;;; 'callargs (lambda calls with args that don't
103 ;;; match the lambda's definition) 103 ;;; match the lambda's definition)
104 ;;; 'subr-callargs (calls to subrs with args that
105 ;;; don't match the subr's definition)
104 ;;; 'redefine (function cell redefined from 106 ;;; 'redefine (function cell redefined from
105 ;;; a macro to a lambda or vice versa, 107 ;;; a macro to a lambda or vice versa,
106 ;;; or redefined to take other args) 108 ;;; or redefined to take other args)
107 ;;; 'obsolete (obsolete variables and functions) 109 ;;; 'obsolete (obsolete variables and functions)
108 ;;; 'pedantic (references to Emacs-compatible 110 ;;; 'pedantic (references to Emacs-compatible
169 ;;; 171 ;;;
170 ;;; o If you run byte-compile-file on a filename which is visited in a 172 ;;; o If you run byte-compile-file on a filename which is visited in a
171 ;;; buffer, and that buffer is modified, you are asked whether you want 173 ;;; buffer, and that buffer is modified, you are asked whether you want
172 ;;; to save the buffer before compiling. 174 ;;; to save the buffer before compiling.
173 ;;; 175 ;;;
174 ;;; o You can add this to /etc/magic to make file(1) recognise the files 176 ;;; o You can add this to /etc/magic to make file(1) recognize the files
175 ;;; generated by this compiler: 177 ;;; generated by this compiler:
176 ;;; 178 ;;;
177 ;;; 0 string ;ELC GNU Emacs Lisp compiled file, 179 ;;; 0 string ;ELC GNU Emacs Lisp compiled file,
178 ;;; >4 byte x version %d 180 ;;; >4 byte x version %d
179 ;;; 181 ;;;
208 (defvar byte-compile-single-version nil 210 (defvar byte-compile-single-version nil
209 "If this is true, the choice of emacs version (v19 or v20) byte-codes will 211 "If this is true, the choice of emacs version (v19 or v20) byte-codes will
210 be hard-coded into bytecomp when it compiles itself. If the compiler itself 212 be hard-coded into bytecomp when it compiles itself. If the compiler itself
211 is compiled with optimization, this causes a speedup.") 213 is compiled with optimization, this causes a speedup.")
212 214
213 (cond (byte-compile-single-version 215 (cond
214 (defmacro byte-compile-single-version () t) 216 (byte-compile-single-version
215 (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond)))) 217 (defmacro byte-compile-single-version () t)
216 (t 218 (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond))))
217 (defmacro byte-compile-single-version () nil) 219 (t
218 (defmacro byte-compile-version-cond (cond) cond))) 220 (defmacro byte-compile-single-version () nil)
221 (defmacro byte-compile-version-cond (cond) cond)))
219 ) 222 )
220 223
221 (defvar emacs-lisp-file-regexp (if (eq system-type 'vax-vms) 224 (defvar emacs-lisp-file-regexp (purecopy "\\.el$")
222 (purecopy "\\.EL\\(;[0-9]+\\)?$")
223 (purecopy "\\.el$"))
224 "*Regexp which matches Emacs Lisp source files. 225 "*Regexp which matches Emacs Lisp source files.
225 You may want to redefine `byte-compile-dest-file' if you change this.") 226 You may want to redefine `byte-compile-dest-file' if you change this.")
226 227
227 ;; This enables file name handlers such as jka-compr 228 ;; This enables file name handlers such as jka-compr
228 ;; to remove parts of the file name that should not be copied 229 ;; to remove parts of the file name that should not be copied
232 'byte-compiler-base-file-name))) 233 'byte-compiler-base-file-name)))
233 (if handler 234 (if handler
234 (funcall handler 'byte-compiler-base-file-name filename) 235 (funcall handler 'byte-compiler-base-file-name filename)
235 filename))) 236 filename)))
236 237
237 (or (fboundp 'byte-compile-dest-file) 238 (unless (fboundp 'byte-compile-dest-file)
238 ;; The user may want to redefine this along with emacs-lisp-file-regexp, 239 ;; The user may want to redefine this along with emacs-lisp-file-regexp,
239 ;; so only define it if it is undefined. 240 ;; so only define it if it is undefined.
240 (defun byte-compile-dest-file (filename) 241 (defun byte-compile-dest-file (filename)
241 "Convert an Emacs Lisp source file name to a compiled file name." 242 "Convert an Emacs Lisp source file name to a compiled file name."
242 (setq filename (byte-compiler-base-file-name filename)) 243 (setq filename (byte-compiler-base-file-name filename))
243 (setq filename (file-name-sans-versions filename)) 244 (setq filename (file-name-sans-versions filename))
244 (cond ((eq system-type 'vax-vms) 245 (if (string-match emacs-lisp-file-regexp filename)
245 (concat (substring filename 0 (string-match ";" filename)) "c")) 246 (concat (substring filename 0 (match-beginning 0)) ".elc")
246 ((string-match emacs-lisp-file-regexp filename) 247 (concat filename ".elc"))))
247 (concat (substring filename 0 (match-beginning 0)) ".elc"))
248 (t (concat filename ".elc")))))
249 248
250 ;; This can be the 'byte-compile property of any symbol. 249 ;; This can be the 'byte-compile property of any symbol.
251 (autoload 'byte-compile-inline-expand "byte-optimize") 250 (autoload 'byte-compile-inline-expand "byte-optimize")
252 251
253 ;; This is the entrypoint to the lapcode optimizer pass1. 252 ;; This is the entrypoint to the lapcode optimizer pass1.
258 257
259 ;; This is the entry point to the decompiler, which is used by the 258 ;; This is the entry point to the decompiler, which is used by the
260 ;; disassembler. The disassembler just requires 'byte-compile, but 259 ;; disassembler. The disassembler just requires 'byte-compile, but
261 ;; that doesn't define this function, so this seems to be a reasonable 260 ;; that doesn't define this function, so this seems to be a reasonable
262 ;; thing to do. 261 ;; thing to do.
263 (autoload 'byte-decompile-bytecode "byte-opt") 262 (autoload 'byte-decompile-bytecode "byte-optimize")
264 263
265 (defvar byte-compile-verbose 264 (defvar byte-compile-verbose
266 (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) 265 (and (not noninteractive) (> (device-baud-rate) search-slow-speed))
267 "*Non-nil means print messages describing progress of byte-compiler.") 266 "*Non-nil means print messages describing progress of byte-compiler.")
268 267
348 (defvar byte-compile-error-on-warn nil 347 (defvar byte-compile-error-on-warn nil
349 "*If true, the byte-compiler reports warnings with `error'.") 348 "*If true, the byte-compiler reports warnings with `error'.")
350 349
351 ;; byte-compile-warning-types in FSF. 350 ;; byte-compile-warning-types in FSF.
352 (defvar byte-compile-default-warnings 351 (defvar byte-compile-default-warnings
353 '(redefine callargs free-vars unresolved unused-vars obsolete) 352 '(redefine callargs subr-callargs free-vars unresolved unused-vars obsolete)
354 "*The warnings used when byte-compile-warnings is t.") 353 "*The warnings used when byte-compile-warnings is t.")
355 354
356 (defvar byte-compile-warnings t 355 (defvar byte-compile-warnings t
357 "*List of warnings that the compiler should issue (t for the default set). 356 "*List of warnings that the compiler should issue (t for the default set).
358 Elements of the list may be: 357 Elements of the list may be:
359 358
360 free-vars references to variables not in the current lexical scope. 359 free-vars references to variables not in the current lexical scope.
361 unused-vars references to non-global variables bound but not referenced. 360 unused-vars references to non-global variables bound but not referenced.
362 unresolved calls to unknown functions. 361 unresolved calls to unknown functions.
363 callargs lambda calls with args that don't match the definition. 362 callargs lambda calls with args that don't match the definition.
363 subr-callargs calls to subrs with args that don't match the definition.
364 redefine function cell redefined from a macro to a lambda or vice 364 redefine function cell redefined from a macro to a lambda or vice
365 versa, or redefined to take a different number of arguments. 365 versa, or redefined to take a different number of arguments.
366 obsolete use of an obsolete function or variable. 366 obsolete use of an obsolete function or variable.
367 pedantic warn of use of compatible symbols. 367 pedantic warn of use of compatible symbols.
368 368
371 371
372 See also the macro `byte-compiler-options'.") 372 See also the macro `byte-compiler-options'.")
373 373
374 (defvar byte-compile-generate-call-tree nil 374 (defvar byte-compile-generate-call-tree nil
375 "*Non-nil means collect call-graph information when compiling. 375 "*Non-nil means collect call-graph information when compiling.
376 This records functions were called and from where. 376 This records functions that were called and from where.
377 If the value is t, compilation displays the call graph when it finishes. 377 If the value is t, compilation displays the call graph when it finishes.
378 If the value is neither t nor nil, compilation asks you whether to display 378 If the value is neither t nor nil, compilation asks you whether to display
379 the graph. 379 the graph.
380 380
381 The call tree only lists functions called, not macros used. Those functions 381 The call tree only lists functions called, not macros used. Those functions
430 (defconst byte-compile-arglist-bit 4) 430 (defconst byte-compile-arglist-bit 4)
431 (defconst byte-compile-global-bit 8) 431 (defconst byte-compile-global-bit 8)
432 432
433 (defvar byte-compile-free-references) 433 (defvar byte-compile-free-references)
434 (defvar byte-compile-free-assignments) 434 (defvar byte-compile-free-assignments)
435 (defvar debug-issue-ebola-notices)
435 436
436 (defvar byte-compiler-error-flag) 437 (defvar byte-compiler-error-flag)
437 438
438 (defconst byte-compile-initial-macro-environment 439 (defconst byte-compile-initial-macro-environment
439 (purecopy 440 (purecopy
618 "to pop value and jump if it's not nil") 619 "to pop value and jump if it's not nil")
619 (byte-defop 133 -1 byte-goto-if-nil-else-pop 620 (byte-defop 133 -1 byte-goto-if-nil-else-pop
620 "to examine top-of-stack, jump and don't pop it if it's nil, 621 "to examine top-of-stack, jump and don't pop it if it's nil,
621 otherwise pop it") 622 otherwise pop it")
622 (byte-defop 134 -1 byte-goto-if-not-nil-else-pop 623 (byte-defop 134 -1 byte-goto-if-not-nil-else-pop
623 "to examine top-of-stack, jump and don't pop it if it's non nil, 624 "to examine top-of-stack, jump and don't pop it if it's non-nil,
624 otherwise pop it") 625 otherwise pop it")
625 626
626 (byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'") 627 (byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'")
627 (byte-defop 136 -1 byte-discard "to discard one value from stack") 628 (byte-defop 136 -1 byte-discard "to discard one value from stack")
628 (byte-defop 137 1 byte-dup "to duplicate the top of the stack") 629 (byte-defop 137 1 byte-dup "to duplicate the top of the stack")
768 off (cdr (car lap))) 769 off (cdr (car lap)))
769 (cond ((not (symbolp op)) 770 (cond ((not (symbolp op))
770 (error "Non-symbolic opcode `%s'" op)) 771 (error "Non-symbolic opcode `%s'" op))
771 ((eq op 'TAG) 772 ((eq op 'TAG)
772 (setcar off pc) 773 (setcar off pc)
773 (setq patchlist (cons off patchlist))) 774 (push off patchlist))
774 ((memq op byte-goto-ops) 775 ((memq op byte-goto-ops)
775 (setq pc (+ pc 3)) 776 (setq pc (+ pc 3))
776 (setq bytes (cons (cons pc (cdr off)) 777 (setq bytes (cons (cons pc (cdr off))
777 (cons nil 778 (cons nil
778 (cons (symbol-value op) bytes)))) 779 (cons (symbol-value op) bytes))))
779 (setq patchlist (cons bytes patchlist))) 780 (push bytes patchlist))
780 (t 781 (t
781 (setq bytes 782 (setq bytes
782 (cond ((cond ((consp off) 783 (cond ((cond ((consp off)
783 ;; Variable or constant reference 784 ;; Variable or constant reference
784 (setq off (cdr off)) 785 (setq off (cdr off))
857 (defvar byte-compile-current-form nil) 858 (defvar byte-compile-current-form nil)
858 (defvar byte-compile-current-file nil) 859 (defvar byte-compile-current-file nil)
859 (defvar byte-compile-dest-file nil) 860 (defvar byte-compile-dest-file nil)
860 861
861 (defmacro byte-compile-log (format-string &rest args) 862 (defmacro byte-compile-log (format-string &rest args)
862 (list 'and 863 `(when (and byte-optimize (memq byte-optimize-log '(t source)))
863 'byte-optimize 864 (let ((print-escape-newlines t)
864 '(memq byte-optimize-log '(t source)) 865 (print-level 4)
865 (list 'let '((print-escape-newlines t) 866 (print-length 4))
866 (print-level 4) 867 (byte-compile-log-1 (format ,format-string ,@args)))))
867 (print-length 4)) 868
868 (list 'byte-compile-log-1 869 (defconst byte-compile-last-warned-form 'nothing)
869 (cons 'format
870 (cons format-string
871 (mapcar
872 '(lambda (x)
873 (if (symbolp x) (list 'prin1-to-string x) x))
874 args)))))))
875
876 (defconst byte-compile-last-warned-form nil)
877 870
878 ;; Log a message STRING in *Compile-Log*. 871 ;; Log a message STRING in *Compile-Log*.
879 ;; Also log the current function and file if not already done. 872 ;; Also log the current function and file if not already done.
880 (defun byte-compile-log-1 (string &optional fill) 873 (defun byte-compile-log-1 (string &optional fill)
881 (let ((this-form (or byte-compile-current-form "toplevel forms"))) 874 (let* ((this-form (or byte-compile-current-form "toplevel forms"))
882 (cond 875 (while-compiling-msg
883 (noninteractive 876 (when (or byte-compile-current-file
884 (if (or byte-compile-current-file 877 (not (eq this-form byte-compile-last-warned-form)))
885 (and byte-compile-last-warned-form 878 (format
886 (not (eq this-form byte-compile-last-warned-form)))) 879 "While compiling %s%s:"
887 (message 880 this-form
888 (format "While compiling %s%s:" 881 (cond
889 this-form 882 ((stringp byte-compile-current-file)
890 (if byte-compile-current-file 883 (concat " in file " byte-compile-current-file))
891 (if (stringp byte-compile-current-file) 884 ((bufferp byte-compile-current-file)
892 (concat " in file " byte-compile-current-file) 885 (concat " in buffer "
893 (concat " in buffer " 886 (buffer-name byte-compile-current-file)))
894 (buffer-name byte-compile-current-file))) 887 (""))))))
895 "")))) 888 (if noninteractive
896 (message " %s" string)) 889 (progn
897 (t 890 (when while-compiling-msg (message "%s" while-compiling-msg))
898 (save-excursion 891 (message " %s" string))
899 (set-buffer (get-buffer-create "*Compile-Log*")) 892 (with-current-buffer (get-buffer-create "*Compile-Log*")
900 (goto-char (point-max)) 893 (goto-char (point-max))
901 (cond ((or byte-compile-current-file 894 (when byte-compile-current-file
902 (and byte-compile-last-warned-form 895 (when (> (point-max) (point-min))
903 (not (eq this-form byte-compile-last-warned-form)))) 896 (insert "\n\^L\n"))
904 (if byte-compile-current-file 897 (insert (current-time-string) "\n"))
905 (insert "\n\^L\n" (current-time-string) "\n")) 898 (when while-compiling-msg (insert while-compiling-msg "\n"))
906 (insert "While compiling "
907 (if (stringp this-form) this-form
908 (format "%s" this-form)))
909 (if byte-compile-current-file
910 (if (stringp byte-compile-current-file)
911 (insert " in file " byte-compile-current-file)
912 (insert " in buffer "
913 (buffer-name byte-compile-current-file))))
914 (insert ":\n")))
915 (insert " " string "\n") 899 (insert " " string "\n")
916 (if (and fill (not (string-match "\n" string))) 900 (when (and fill (not (string-match "\n" string)))
917 (let ((fill-prefix " ") 901 (let ((fill-prefix " ")
918 (fill-column 78)) 902 (fill-column 78))
919 (fill-paragraph nil))) 903 (fill-paragraph nil)))))
920 ))) 904 (setq byte-compile-current-file nil)
921 (setq byte-compile-current-file nil 905 (setq byte-compile-last-warned-form this-form)))
922 byte-compile-last-warned-form this-form)))
923 906
924 ;; Log the start of a file in *Compile-Log*, and mark it as done. 907 ;; Log the start of a file in *Compile-Log*, and mark it as done.
925 ;; But do nothing in batch mode. 908 ;; But do nothing in batch mode.
926 (defun byte-compile-log-file () 909 (defun byte-compile-log-file ()
927 (and byte-compile-current-file (not noninteractive) 910 (when (and byte-compile-current-file (not noninteractive))
928 (save-excursion 911 (with-current-buffer (get-buffer-create "*Compile-Log*")
929 (set-buffer (get-buffer-create "*Compile-Log*")) 912 (when (> (point-max) (point-min))
930 (goto-char (point-max)) 913 (goto-char (point-max))
931 (insert "\n\^L\nCompiling " 914 (insert "\n\^L\n"))
932 (if (stringp byte-compile-current-file) 915 (insert "Compiling "
933 (concat "file " byte-compile-current-file) 916 (if (stringp byte-compile-current-file)
934 (concat "buffer " (buffer-name byte-compile-current-file))) 917 (concat "file " byte-compile-current-file)
935 " at " (current-time-string) "\n") 918 (concat "buffer " (buffer-name byte-compile-current-file)))
936 (setq byte-compile-current-file nil)))) 919 " at " (current-time-string) "\n")
920 (setq byte-compile-current-file nil))))
937 921
938 (defun byte-compile-warn (format &rest args) 922 (defun byte-compile-warn (format &rest args)
939 (setq format (apply 'format format args)) 923 (setq format (apply 'format format args))
940 (if byte-compile-error-on-warn 924 (if byte-compile-error-on-warn
941 (error "%s" format) ; byte-compile-file catches and logs it 925 (error "%s" format) ; byte-compile-file catches and logs it
985 (eq val 'emacs19)) 969 (eq val 'emacs19))
986 (delete-errors byte-compile-delete-errors (t nil) val) 970 (delete-errors byte-compile-delete-errors (t nil) val)
987 (verbose byte-compile-verbose (t nil) val) 971 (verbose byte-compile-verbose (t nil) val)
988 (new-bytecodes byte-compile-new-bytecodes (t nil) val) 972 (new-bytecodes byte-compile-new-bytecodes (t nil) val)
989 (warnings byte-compile-warnings 973 (warnings byte-compile-warnings
990 ((callargs redefine free-vars unused-vars unresolved)) 974 ((callargs subr-callargs redefine free-vars unused-vars unresolved))
991 val))) 975 val)))
992 976
993 ;; XEmacs addition 977 ;; XEmacs addition
994 (defconst byte-compiler-obsolete-options 978 (defconst byte-compiler-obsolete-options
995 '((new-bytecodes t))) 979 '((new-bytecodes t)))
1223 (byte-compile-warn "the function %s is not known to be defined." 1207 (byte-compile-warn "the function %s is not known to be defined."
1224 (car (car byte-compile-unresolved-functions))))))) 1208 (car (car byte-compile-unresolved-functions)))))))
1225 nil) 1209 nil)
1226 1210
1227 (defun byte-compile-defvar-p (var) 1211 (defun byte-compile-defvar-p (var)
1228 ;; Whether the byte compiler thinks that nonexical references to this 1212 ;; Whether the byte compiler thinks that non-lexical references to this
1229 ;; variable are ok. 1213 ;; variable are ok.
1230 (or (globally-boundp var) 1214 (or (globally-boundp var)
1231 (let ((rest byte-compile-bound-variables)) 1215 (let ((rest byte-compile-bound-variables))
1232 (while (and rest var) 1216 (while (and rest var)
1233 (if (and (eq var (car-safe (car rest))) 1217 (if (and (eq var (car-safe (car rest)))
1255 ;; for two reasons: first, the arglist structure 1239 ;; for two reasons: first, the arglist structure
1256 ;; might be imposed by external forces, and we don't 1240 ;; might be imposed by external forces, and we don't
1257 ;; have (declare (ignore x)) yet; and second, inline 1241 ;; have (declare (ignore x)) yet; and second, inline
1258 ;; expansion produces forms like 1242 ;; expansion produces forms like
1259 ;; ((lambda (arg) (byte-code "..." [arg])) x) 1243 ;; ((lambda (arg) (byte-code "..." [arg])) x)
1260 ;; which we can't (ok, well, don't) recognise as 1244 ;; which we can't (ok, well, don't) recognize as
1261 ;; containing a reference to arg, so every inline 1245 ;; containing a reference to arg, so every inline
1262 ;; expansion would generate a warning. (If we had 1246 ;; expansion would generate a warning. (If we had
1263 ;; `ignore' then inline expansion could emit an 1247 ;; `ignore' then inline expansion could emit an
1264 ;; ignore declaration.) 1248 ;; ignore declaration.)
1265 (= 0 (logand byte-compile-arglist-bit (cdr cell))) 1249 (= 0 (logand byte-compile-arglist-bit (cdr cell)))
1273 (byte-compile-warn 1257 (byte-compile-warn
1274 (format "variable %s bound but not referenced" (car unreferenced))) 1258 (format "variable %s bound but not referenced" (car unreferenced)))
1275 (setq unreferenced (cdr unreferenced))))) 1259 (setq unreferenced (cdr unreferenced)))))
1276 1260
1277 1261
1262 (defmacro byte-compile-constant-symbol-p (symbol)
1263 `(or (keywordp ,symbol) (memq ,symbol '(nil t))))
1264
1278 (defmacro byte-compile-constp (form) 1265 (defmacro byte-compile-constp (form)
1279 ;; Returns non-nil if FORM is a constant. 1266 ;; Returns non-nil if FORM is a constant.
1280 (` (cond ((consp (, form)) (eq (car (, form)) 'quote)) 1267 `(cond ((consp ,form) (eq (car ,form) 'quote))
1281 ((not (symbolp (, form)))) 1268 ((symbolp ,form) (byte-compile-constant-symbol-p ,form))
1282 ((keywordp (, form))) 1269 (t)))
1283 ((memq (, form) '(nil t))))))
1284 1270
1285 (defmacro byte-compile-close-variables (&rest body) 1271 (defmacro byte-compile-close-variables (&rest body)
1286 `(let 1272 `(let
1287 (;; 1273 (;;
1288 ;; Close over these variables to encapsulate the 1274 ;; Close over these variables to encapsulate the
1311 byte-compile-dynamic-docstrings) 1297 byte-compile-dynamic-docstrings)
1312 (byte-compile-warnings (if (eq byte-compile-warnings t) 1298 (byte-compile-warnings (if (eq byte-compile-warnings t)
1313 byte-compile-default-warnings 1299 byte-compile-default-warnings
1314 byte-compile-warnings)) 1300 byte-compile-warnings))
1315 (byte-compile-file-domain nil) 1301 (byte-compile-file-domain nil)
1302
1303 ;; We reserve the right to compare ANY objects for equality.
1304 (debug-issue-ebola-notices -42)
1316 ) 1305 )
1317 (prog1 1306 (prog1
1318 (progn ,@body) 1307 (progn ,@body)
1319 (if (memq 'unused-vars byte-compile-warnings) 1308 (if (memq 'unused-vars byte-compile-warnings)
1320 ;; done compiling in this scope, warn now. 1309 ;; done compiling in this scope, warn now.
1321 (byte-compile-warn-about-unused-variables))))) 1310 (byte-compile-warn-about-unused-variables)))))
1322 1311
1323 1312
1324 (defvar byte-compile-warnings-point-max nil)
1325 (defmacro displaying-byte-compile-warnings (&rest body) 1313 (defmacro displaying-byte-compile-warnings (&rest body)
1326 `(let ((byte-compile-warnings-point-max byte-compile-warnings-point-max)) 1314 `(let* ((byte-compile-log-buffer (get-buffer-create "*Compile-Log*"))
1327 ;; Log the file name. 1315 (byte-compile-point-max-prev (point-max byte-compile-log-buffer)))
1316 ;; Log the file name or buffer name.
1328 (byte-compile-log-file) 1317 (byte-compile-log-file)
1329 ;; Record how much is logged now. 1318 ;; Record how much is logged now.
1330 ;; We will display the log buffer if anything more is logged 1319 ;; We will display the log buffer if anything more is logged
1331 ;; before the end of BODY. 1320 ;; before the end of BODY.
1332 (or byte-compile-warnings-point-max 1321 (defvar byte-compile-warnings-beginning)
1333 (save-excursion 1322 (let ((byte-compile-warnings-beginning
1334 (set-buffer (get-buffer-create "*Compile-Log*")) 1323 (if (boundp 'byte-compile-warnings-beginning)
1335 (setq byte-compile-warnings-point-max (point-max)))) 1324 byte-compile-warnings-beginning
1336 (unwind-protect 1325 (point-max byte-compile-log-buffer))))
1337 (condition-case error-info 1326
1338 (progn ,@body) 1327 (unwind-protect
1339 (error 1328 (condition-case error-info
1340 (byte-compile-report-error error-info))) 1329 (progn ,@body)
1341 (save-excursion 1330 (error
1342 ;; If there were compilation warnings, display them. 1331 (byte-compile-report-error error-info)))
1343 (set-buffer "*Compile-Log*") 1332
1344 (if (= byte-compile-warnings-point-max (point-max)) 1333 ;; Always set point in log to start of interesting output.
1345 nil 1334 (with-current-buffer byte-compile-log-buffer
1346 (if temp-buffer-show-function 1335 (let ((show-begin
1347 (let ((show-buffer (get-buffer-create "*Compile-Log-Show*"))) 1336 (progn (goto-char byte-compile-point-max-prev)
1348 (save-excursion 1337 (skip-chars-forward "\^L\n")
1349 (set-buffer show-buffer) 1338 (point))))
1350 (setq buffer-read-only nil) 1339 ;; If there were compilation warnings, display them.
1351 (erase-buffer)) 1340 (if temp-buffer-show-function
1352 (copy-to-buffer show-buffer 1341 (let ((show-buffer (get-buffer-create "*Compile-Log-Show*")))
1353 (save-excursion 1342 ;; Always clean show-buffer, even when not displaying it,
1354 (goto-char byte-compile-warnings-point-max) 1343 ;; so that misleading previous messages aren't left around.
1355 (forward-line -1) 1344 (with-current-buffer show-buffer
1356 (point)) 1345 (setq buffer-read-only nil)
1357 (point-max)) 1346 (erase-buffer))
1358 (funcall temp-buffer-show-function show-buffer)) 1347 (copy-to-buffer show-buffer show-begin (point-max))
1359 (select-window 1348 (when (< byte-compile-warnings-beginning (point-max))
1360 (prog1 (selected-window) 1349 (funcall temp-buffer-show-function show-buffer)))
1361 (select-window (display-buffer (current-buffer))) 1350 (when (< byte-compile-warnings-beginning (point-max))
1362 (goto-char byte-compile-warnings-point-max) 1351 (select-window
1363 (recenter 1))))))))) 1352 (prog1 (selected-window)
1353 (select-window (display-buffer (current-buffer)))
1354 (goto-char show-begin)
1355 (recenter 1)))))))))))
1364 1356
1365 1357
1366 ;;;###autoload 1358 ;;;###autoload
1367 (defun byte-force-recompile (directory) 1359 (defun byte-force-recompile (directory)
1368 "Recompile every `.el' file in DIRECTORY that already has a `.elc' file. 1360 "Recompile every `.el' file in DIRECTORY that already has a `.elc' file.
1464 (and force 1456 (and force
1465 (or (eq 0 force) 1457 (or (eq 0 force)
1466 (y-or-n-p (concat "Compile " filename "? ")))))) 1458 (y-or-n-p (concat "Compile " filename "? "))))))
1467 (byte-compile-file filename)))) 1459 (byte-compile-file filename))))
1468 1460
1469 (defvar kanji-flag nil)
1470
1471 ;;;###autoload 1461 ;;;###autoload
1472 (defun byte-compile-file (filename &optional load) 1462 (defun byte-compile-file (filename &optional load)
1473 "Compile a file of Lisp code named FILENAME into a file of byte code. 1463 "Compile a file of Lisp code named FILENAME into a file of byte code.
1474 The output file's name is made by appending `c' to the end of FILENAME. 1464 The output file's name is made by appending `c' to the end of FILENAME.
1475 With prefix arg (noninteractively: 2nd arg), load the file after compiling." 1465 With prefix arg (noninteractively: 2nd arg), load the file after compiling."
1501 1491
1502 (if (or noninteractive byte-compile-verbose) ; XEmacs change 1492 (if (or noninteractive byte-compile-verbose) ; XEmacs change
1503 (message "Compiling %s..." filename)) 1493 (message "Compiling %s..." filename))
1504 (let (;;(byte-compile-current-file (file-name-nondirectory filename)) 1494 (let (;;(byte-compile-current-file (file-name-nondirectory filename))
1505 (byte-compile-current-file filename) 1495 (byte-compile-current-file filename)
1506 (debug-issue-ebola-notices 0) ; Hack -slb
1507 target-file input-buffer output-buffer 1496 target-file input-buffer output-buffer
1508 byte-compile-dest-file) 1497 byte-compile-dest-file)
1509 (setq target-file (byte-compile-dest-file filename)) 1498 (setq target-file (byte-compile-dest-file filename))
1510 (setq byte-compile-dest-file target-file) 1499 (setq byte-compile-dest-file target-file)
1511 (save-excursion 1500 (save-excursion
1532 (kill-buffer input-buffer) 1521 (kill-buffer input-buffer)
1533 (save-excursion 1522 (save-excursion
1534 (set-buffer output-buffer) 1523 (set-buffer output-buffer)
1535 (goto-char (point-max)) 1524 (goto-char (point-max))
1536 (insert "\n") ; aaah, unix. 1525 (insert "\n") ; aaah, unix.
1537 (let ((vms-stmlf-recfm t)) 1526 (setq target-file (byte-compile-dest-file filename))
1538 (setq target-file (byte-compile-dest-file filename)) 1527 (unless byte-compile-overwrite-file
1539 (or byte-compile-overwrite-file 1528 (ignore-file-errors (delete-file target-file)))
1540 (condition-case () 1529 (if (file-writable-p target-file)
1541 (delete-file target-file) 1530 (progn
1542 (error nil))) 1531 (when (memq system-type '(ms-dos windows-nt))
1543 (if (file-writable-p target-file) 1532 (defvar buffer-file-type)
1544 (let ((kanji-flag nil)) ; for nemacs, from Nakagawa Takayuki 1533 (setq buffer-file-type t))
1545 (if (or (eq system-type 'ms-dos) (eq system-type 'windows-nt)) 1534 (write-region 1 (point-max) target-file))
1546 (setq buffer-file-type t)) 1535 ;; This is just to give a better error message than write-region
1547 (write-region 1 (point-max) target-file)) 1536 (signal 'file-error
1548 ;; This is just to give a better error message than write-region 1537 (list "Opening output file"
1549 (signal 'file-error 1538 (if (file-exists-p target-file)
1550 (list "Opening output file" 1539 "cannot overwrite file"
1551 (if (file-exists-p target-file) 1540 "directory not writable or nonexistent")
1552 "cannot overwrite file" 1541 target-file)))
1553 "directory not writable or nonexistent") 1542 (or byte-compile-overwrite-file
1554 target-file))) 1543 (condition-case ()
1555 (or byte-compile-overwrite-file 1544 (set-file-modes target-file (file-modes filename))
1556 (condition-case () 1545 (error nil)))
1557 (set-file-modes target-file (file-modes filename))
1558 (error nil))))
1559 (kill-buffer (current-buffer))) 1546 (kill-buffer (current-buffer)))
1560 (if (and byte-compile-generate-call-tree 1547 (if (and byte-compile-generate-call-tree
1561 (or (eq t byte-compile-generate-call-tree) 1548 (or (eq t byte-compile-generate-call-tree)
1562 (y-or-n-p (format "Report call tree for %s? " filename)))) 1549 (y-or-n-p (format "Report call tree for %s? " filename))))
1563 (save-excursion 1550 (save-excursion
1662 (set-buffer byte-compile-inbuffer) 1649 (set-buffer byte-compile-inbuffer)
1663 (goto-char 1) 1650 (goto-char 1)
1664 1651
1665 ;; Compile the forms from the input buffer. 1652 ;; Compile the forms from the input buffer.
1666 (while (progn 1653 (while (progn
1667 (while (progn (skip-chars-forward " \t\n\^l") 1654 (while (progn (skip-chars-forward " \t\n\^L")
1668 (looking-at ";")) 1655 (looking-at ";"))
1669 (forward-line 1)) 1656 (forward-line 1))
1670 (not (eobp))) 1657 (not (eobp)))
1671 (byte-compile-file-form (read byte-compile-inbuffer))) 1658 (byte-compile-file-form (read byte-compile-inbuffer)))
1672 1659
1765 ;; file if under Mule. If there are any extended characters in the 1752 ;; file if under Mule. If there are any extended characters in the
1766 ;; input file, use `escape-quoted' to make sure that both binary and 1753 ;; input file, use `escape-quoted' to make sure that both binary and
1767 ;; extended characters are output properly and distinguished properly. 1754 ;; extended characters are output properly and distinguished properly.
1768 ;; Otherwise, use `no-conversion' for maximum portability with non-Mule 1755 ;; Otherwise, use `no-conversion' for maximum portability with non-Mule
1769 ;; Emacsen. 1756 ;; Emacsen.
1770 (if (featurep 'mule) 1757 (when (featurep 'mule)
1771 (if (save-excursion 1758 (defvar buffer-file-coding-system)
1772 (set-buffer byte-compile-inbuffer) 1759 (if (save-excursion
1773 (goto-char (point-min))
1774 ;; mrb- There must be a better way than skip-chars-forward
1775 (skip-chars-forward (concat (char-to-string 0) "-"
1776 (char-to-string 255)))
1777 (eq (point) (point-max)))
1778 (setq buffer-file-coding-system 'no-conversion)
1779 (insert "(require 'mule)\n;;;###coding system: escape-quoted\n")
1780 (setq buffer-file-coding-system 'escape-quoted)
1781 ;; Lazy loading not yet implemented for MULE files
1782 ;; mrb - Fix this someday.
1783 (save-excursion
1784 (set-buffer byte-compile-inbuffer) 1760 (set-buffer byte-compile-inbuffer)
1785 (setq byte-compile-dynamic nil 1761 (goto-char (point-min))
1786 byte-compile-dynamic-docstrings nil)) 1762 ;; mrb- There must be a better way than skip-chars-forward
1787 ;;(external-debugging-output (prin1-to-string (buffer-local-variables)))) 1763 (skip-chars-forward (concat (char-to-string 0) "-"
1788 )) 1764 (char-to-string 255)))
1765 (eq (point) (point-max)))
1766 (setq buffer-file-coding-system 'no-conversion)
1767 (insert "(require 'mule)\n;;;###coding system: escape-quoted\n")
1768 (setq buffer-file-coding-system 'escape-quoted)
1769 ;; #### Lazy loading not yet implemented for MULE files
1770 ;; mrb - Fix this someday.
1771 (save-excursion
1772 (set-buffer byte-compile-inbuffer)
1773 (setq byte-compile-dynamic nil
1774 byte-compile-dynamic-docstrings nil))
1775 ;;(external-debugging-output (prin1-to-string (buffer-local-variables))))
1776 ))
1789 ) 1777 )
1790 1778
1791 1779
1792 (defun byte-compile-output-file-form (form) 1780 (defun byte-compile-output-file-form (form)
1793 ;; writes the given form to the output buffer, being careful of docstrings 1781 ;; writes the given form to the output buffer, being careful of docstrings
1902 ;; the output regularly. 1890 ;; the output regularly.
1903 (and (memq (car-safe form) '(fset defalias define-function)) 1891 (and (memq (car-safe form) '(fset defalias define-function))
1904 (nthcdr 300 byte-compile-output) 1892 (nthcdr 300 byte-compile-output)
1905 (byte-compile-flush-pending)) 1893 (byte-compile-flush-pending))
1906 (funcall handler form) 1894 (funcall handler form)
1907 (if for-effect 1895 (when for-effect
1908 (byte-compile-discard))) 1896 (byte-compile-discard)))
1909 (byte-compile-form form t)) 1897 (byte-compile-form form t))
1910 nil) 1898 nil)
1911 1899
1912 (defun byte-compile-flush-pending () 1900 (defun byte-compile-flush-pending ()
1913 (if byte-compile-output 1901 (if byte-compile-output
1937 (byte-compile-keep-pending form)) 1925 (byte-compile-keep-pending form))
1938 (t 1926 (t
1939 (byte-compile-file-form form))))) 1927 (byte-compile-file-form form)))))
1940 1928
1941 ;; Functions and variables with doc strings must be output separately, 1929 ;; Functions and variables with doc strings must be output separately,
1942 ;; so make-docfile can recognise them. Most other things can be output 1930 ;; so make-docfile can recognize them. Most other things can be output
1943 ;; as byte-code. 1931 ;; as byte-code.
1944 1932
1945 (put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst) 1933 (put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst)
1946 (defun byte-compile-file-form-defsubst (form) 1934 (defun byte-compile-file-form-defsubst (form)
1947 (cond ((assq (nth 1 form) byte-compile-unresolved-functions) 1935 (cond ((assq (nth 1 form) byte-compile-unresolved-functions)
2104 (or (assq name byte-compile-call-tree) 2092 (or (assq name byte-compile-call-tree)
2105 (setq byte-compile-call-tree 2093 (setq byte-compile-call-tree
2106 (cons (list name nil nil) byte-compile-call-tree)))) 2094 (cons (list name nil nil) byte-compile-call-tree))))
2107 2095
2108 (setq byte-compile-current-form name) ; for warnings 2096 (setq byte-compile-current-form name) ; for warnings
2109 (if (memq 'redefine byte-compile-warnings) 2097 (when (memq 'redefine byte-compile-warnings)
2110 (byte-compile-arglist-warn form macrop)) 2098 (byte-compile-arglist-warn form macrop))
2111 (if byte-compile-verbose 2099 (defvar filename) ; #### filename used free
2112 (message "Compiling %s... (%s)" 2100 (when byte-compile-verbose
2113 ;; #### filename used free 2101 (message "Compiling %s... (%s)"
2114 (if filename (file-name-nondirectory filename) "") 2102 (if filename (file-name-nondirectory filename) "")
2115 (nth 1 form))) 2103 (nth 1 form)))
2116 (cond (that-one 2104 (cond (that-one
2117 (if (and (memq 'redefine byte-compile-warnings) 2105 (when (and (memq 'redefine byte-compile-warnings)
2118 ;; hack hack: don't warn when compiling the stubs in 2106 ;; hack hack: don't warn when compiling the stubs in
2119 ;; bytecomp-runtime... 2107 ;; bytecomp-runtime...
2120 (not (assq (nth 1 form) 2108 (not (assq (nth 1 form)
2121 byte-compile-initial-macro-environment))) 2109 byte-compile-initial-macro-environment)))
2122 (byte-compile-warn 2110 (byte-compile-warn
2123 "%s defined multiple times, as both function and macro" 2111 "%s defined multiple times, as both function and macro"
2124 (nth 1 form))) 2112 (nth 1 form)))
2125 (setcdr that-one nil)) 2113 (setcdr that-one nil))
2126 (this-one 2114 (this-one
2127 (if (and (memq 'redefine byte-compile-warnings) 2115 (when (and (memq 'redefine byte-compile-warnings)
2128 ;; hack: don't warn when compiling the magic internal 2116 ;; hack: don't warn when compiling the magic internal
2129 ;; byte-compiler macros in bytecomp-runtime.el... 2117 ;; byte-compiler macros in bytecomp-runtime.el...
2130 (not (assq (nth 1 form) 2118 (not (assq (nth 1 form)
2131 byte-compile-initial-macro-environment))) 2119 byte-compile-initial-macro-environment)))
2132 (byte-compile-warn "%s %s defined multiple times in this file" 2120 (byte-compile-warn "%s %s defined multiple times in this file"
2133 (if macrop "macro" "function") 2121 (if macrop "macro" "function")
2134 (nth 1 form)))) 2122 (nth 1 form))))
2135 ((and (fboundp name) 2123 ((and (fboundp name)
2136 (or (subrp (symbol-function name)) 2124 (or (subrp (symbol-function name))
2137 (eq (car-safe (symbol-function name)) 2125 (eq (car-safe (symbol-function name))
2138 (if macrop 'lambda 'macro)))) 2126 (if macrop 'lambda 'macro))))
2139 (if (memq 'redefine byte-compile-warnings) 2127 (if (memq 'redefine byte-compile-warnings)
2143 (if macrop "function" "macro")) 2131 (if macrop "function" "macro"))
2144 (nth 1 form) 2132 (nth 1 form)
2145 (if macrop "macro" "function"))) 2133 (if macrop "macro" "function")))
2146 ;; shadow existing definition 2134 ;; shadow existing definition
2147 (set this-kind 2135 (set this-kind
2148 (cons (cons name nil) (symbol-value this-kind)))) 2136 (cons (cons name nil) (symbol-value this-kind)))))
2149 )
2150 (let ((body (nthcdr 3 form))) 2137 (let ((body (nthcdr 3 form)))
2151 (if (and (stringp (car body)) 2138 (if (and (stringp (car body))
2152 (symbolp (car-safe (cdr-safe body))) 2139 (symbolp (car-safe (cdr-safe body)))
2153 (car-safe (cdr-safe body)) 2140 (car-safe (cdr-safe body))
2154 (stringp (car-safe (cdr-safe (cdr-safe body))))) 2141 (stringp (car-safe (cdr-safe (cdr-safe body)))))
2343 (null (cdr (memq tmp fun)))) 2330 (null (cdr (memq tmp fun))))
2344 ;; Generate a make-byte-code call. 2331 ;; Generate a make-byte-code call.
2345 (let* ((interactive (assq 'interactive (cdr (cdr fun))))) 2332 (let* ((interactive (assq 'interactive (cdr (cdr fun)))))
2346 (nconc (list 'make-byte-code 2333 (nconc (list 'make-byte-code
2347 (list 'quote (nth 1 fun)) ;arglist 2334 (list 'quote (nth 1 fun)) ;arglist
2348 (nth 1 tmp) ;bytes 2335 (nth 1 tmp) ;instructions
2349 (nth 2 tmp) ;consts 2336 (nth 2 tmp) ;constants
2350 (nth 3 tmp)) ;depth 2337 (nth 3 tmp)) ;stack-depth
2351 (cond ((stringp (nth 2 fun)) 2338 (cond ((stringp (nth 2 fun))
2352 (list (nth 2 fun))) ;doc 2339 (list (nth 2 fun))) ;docstring
2353 (interactive 2340 (interactive
2354 (list nil))) 2341 (list nil)))
2355 (cond (interactive 2342 (cond (interactive
2356 (list (if (or (null (nth 1 interactive)) 2343 (list (if (or (null (nth 1 interactive))
2357 (stringp (nth 1 interactive))) 2344 (stringp (nth 1 interactive)))
2369 (or (eq 'lambda (car-safe fun)) 2356 (or (eq 'lambda (car-safe fun))
2370 (error "not a lambda -- %s" (prin1-to-string fun))) 2357 (error "not a lambda -- %s" (prin1-to-string fun)))
2371 (let* ((arglist (nth 1 fun)) 2358 (let* ((arglist (nth 1 fun))
2372 (byte-compile-bound-variables 2359 (byte-compile-bound-variables
2373 (let ((new-bindings 2360 (let ((new-bindings
2374 (mapcar (function (lambda (x) 2361 (mapcar #'(lambda (x) (cons x byte-compile-arglist-bit))
2375 (cons x byte-compile-arglist-bit)))
2376 (and (memq 'free-vars byte-compile-warnings) 2362 (and (memq 'free-vars byte-compile-warnings)
2377 (delq '&rest (delq '&optional 2363 (delq '&rest (delq '&optional
2378 (copy-sequence arglist))))))) 2364 (copy-sequence arglist)))))))
2379 (nconc new-bindings 2365 (nconc new-bindings
2380 (cons 'new-scope byte-compile-bound-variables)))) 2366 (cons 'new-scope byte-compile-bound-variables))))
2381 (body (cdr (cdr fun))) 2367 (body (cdr (cdr fun)))
2382 (doc (if (stringp (car body)) 2368 (doc (if (stringp (car body))
2383 (prog1 (car body) 2369 (prog1 (car body)
2384 (setq body (cdr body))))) 2370 (setq body (cdr body)))))
2385 (int (assq 'interactive body))) 2371 (int (assq 'interactive body)))
2386 (let ((rest arglist)) 2372 (dolist (arg arglist)
2387 (while rest 2373 (cond ((not (symbolp arg))
2388 (cond ((not (symbolp (car rest))) 2374 (byte-compile-warn "non-symbol in arglist: %S" arg))
2389 (byte-compile-warn "non-symbol in arglist: %s" 2375 ((byte-compile-constant-symbol-p arg)
2390 (prin1-to-string (car rest)))) 2376 (byte-compile-warn "constant symbol in arglist: %s" arg))
2391 ((memq (car rest) '(t nil)) 2377 ((and (char= ?\& (aref (symbol-name arg) 0))
2392 (byte-compile-warn "constant in arglist: %s" (car rest))) 2378 (not (eq arg '&optional))
2393 ((and (char= ?\& (aref (symbol-name (car rest)) 0)) 2379 (not (eq arg '&rest)))
2394 (not (memq (car rest) '(&optional &rest)))) 2380 (byte-compile-warn "unrecognized `&' keyword in arglist: %s"
2395 (byte-compile-warn "unrecognised `&' keyword in arglist: %s" 2381 arg))))
2396 (car rest))))
2397 (setq rest (cdr rest))))
2398 (cond (int 2382 (cond (int
2399 ;; Skip (interactive) if it is in front (the most usual location). 2383 ;; Skip (interactive) if it is in front (the most usual location).
2400 (if (eq int (car body)) 2384 (if (eq int (car body))
2401 (setq body (cdr body))) 2385 (setq body (cdr body)))
2402 (cond ((consp (cdr int)) 2386 (cond ((consp (cdr int))
2553 ((memq (car (car rest)) '(byte-varref byte-constant)) 2537 ((memq (car (car rest)) '(byte-varref byte-constant))
2554 (setq tmp (car (cdr (car rest)))) 2538 (setq tmp (car (cdr (car rest))))
2555 (if (if (eq (car (car rest)) 'byte-constant) 2539 (if (if (eq (car (car rest)) 'byte-constant)
2556 (or (consp tmp) 2540 (or (consp tmp)
2557 (and (symbolp tmp) 2541 (and (symbolp tmp)
2558 (not (keywordp tmp)) 2542 (not (byte-compile-constant-symbol-p tmp)))))
2559 (not (memq tmp '(nil t))))))
2560 (if maycall 2543 (if maycall
2561 (setq body (cons (list 'quote tmp) body))) 2544 (setq body (cons (list 'quote tmp) body)))
2562 (setq body (cons tmp body)))) 2545 (setq body (cons tmp body))))
2563 ((and maycall 2546 ((and maycall
2564 ;; Allow a funcall if at most one atom follows it. 2547 ;; Allow a funcall if at most one atom follows it.
2604 (list body)))) 2587 (list body))))
2605 2588
2606 ;; This is the recursive entry point for compiling each subform of an 2589 ;; This is the recursive entry point for compiling each subform of an
2607 ;; expression. 2590 ;; expression.
2608 ;; If for-effect is non-nil, byte-compile-form will output a byte-discard 2591 ;; If for-effect is non-nil, byte-compile-form will output a byte-discard
2609 ;; before terminating (ie no value will be left on the stack). 2592 ;; before terminating (ie. no value will be left on the stack).
2610 ;; A byte-compile handler may, when for-effect is non-nil, choose output code 2593 ;; A byte-compile handler may, when for-effect is non-nil, choose output code
2611 ;; which does not leave a value on the stack, and then set for-effect to nil 2594 ;; which does not leave a value on the stack, and then set for-effect to nil
2612 ;; (to prevent byte-compile-form from outputting the byte-discard). 2595 ;; (to prevent byte-compile-form from outputting the byte-discard).
2613 ;; If a handler wants to call another handler, it should do so via 2596 ;; If a handler wants to call another handler, it should do so via
2614 ;; byte-compile-form, or take extreme care to handle for-effect correctly. 2597 ;; byte-compile-form, or take extreme care to handle for-effect correctly.
2615 ;; (Use byte-compile-form-do-effect to reset the for-effect flag too.) 2598 ;; (Use byte-compile-form-do-effect to reset the for-effect flag too.)
2616 ;; 2599 ;;
2617 (defun byte-compile-form (form &optional for-effect) 2600 (defun byte-compile-form (form &optional for-effect)
2618 (setq form (macroexpand form byte-compile-macro-environment)) 2601 (setq form (macroexpand form byte-compile-macro-environment))
2619 (cond ((not (consp form)) 2602 (cond ((not (consp form))
2620 ;; XEmacs addition: keywordp 2603 (cond ((or (not (symbolp form))
2621 (cond ((or (not (symbolp form)) (keywordp form) (memq form '(nil t))) 2604 (byte-compile-constant-symbol-p form))
2622 (byte-compile-constant form)) 2605 (byte-compile-constant form))
2623 ((and for-effect byte-compile-delete-errors) 2606 ((and for-effect byte-compile-delete-errors)
2624 (setq for-effect nil)) 2607 (setq for-effect nil))
2625 (t (byte-compile-variable-ref 'byte-varref form)))) 2608 (t (byte-compile-variable-ref 'byte-varref form))))
2626 ((symbolp (car form)) 2609 ((symbolp (car form))
2642 ;; because it was malformed, and we couldn't unfold it. 2625 ;; because it was malformed, and we couldn't unfold it.
2643 (not (eq form (setq form (byte-compile-unfold-lambda form))))) 2626 (not (eq form (setq form (byte-compile-unfold-lambda form)))))
2644 (byte-compile-form form for-effect) 2627 (byte-compile-form form for-effect)
2645 (setq for-effect nil)) 2628 (setq for-effect nil))
2646 ((byte-compile-normal-call form))) 2629 ((byte-compile-normal-call form)))
2647 (if for-effect 2630 (when for-effect
2648 (byte-compile-discard))) 2631 (byte-compile-discard)))
2649 2632
2650 (defun byte-compile-normal-call (form) 2633 (defun byte-compile-normal-call (form)
2651 (if byte-compile-generate-call-tree 2634 (if byte-compile-generate-call-tree
2652 (byte-compile-annotate-call-tree form)) 2635 (byte-compile-annotate-call-tree form))
2653 (byte-compile-push-constant (car form)) 2636 (byte-compile-push-constant (car form))
2656 2639
2657 ;; kludge added to XEmacs to work around the bogosities of a nonlexical lisp. 2640 ;; kludge added to XEmacs to work around the bogosities of a nonlexical lisp.
2658 (or (fboundp 'globally-boundp) (fset 'globally-boundp 'boundp)) 2641 (or (fboundp 'globally-boundp) (fset 'globally-boundp 'boundp))
2659 2642
2660 (defun byte-compile-variable-ref (base-op var &optional varbind-flags) 2643 (defun byte-compile-variable-ref (base-op var &optional varbind-flags)
2661 (if (or (not (symbolp var)) (keywordp var) (memq var '(nil t))) 2644 (if (or (not (symbolp var)) (byte-compile-constant-symbol-p var))
2662 (byte-compile-warn (if (eq base-op 'byte-varbind) 2645 (byte-compile-warn
2663 "Attempt to let-bind %s %s" 2646 (case base-op
2664 "Variable reference to %s %s") 2647 (byte-varref "Variable reference to %s %s")
2665 (if (symbolp var) "constant" "nonvariable") 2648 (byte-varset "Attempt to set %s %s")
2666 (prin1-to-string var)) 2649 (byte-varbind "Attempt to let-bind %s %s"))
2650 (if (symbolp var) "constant symbol" "non-symbol")
2651 var)
2667 (if (and (get var 'byte-obsolete-variable) 2652 (if (and (get var 'byte-obsolete-variable)
2668 (memq 'obsolete byte-compile-warnings)) 2653 (memq 'obsolete byte-compile-warnings))
2669 (let ((ob (get var 'byte-obsolete-variable))) 2654 (let ((ob (get var 'byte-obsolete-variable)))
2670 (byte-compile-warn "%s is an obsolete variable; %s" var 2655 (byte-compile-warn "%s is an obsolete variable; %s" var
2671 (if (stringp ob) 2656 (if (stringp ob)
2707 (setq tmp (list var) 2692 (setq tmp (list var)
2708 byte-compile-variables (cons tmp byte-compile-variables))) 2693 byte-compile-variables (cons tmp byte-compile-variables)))
2709 (byte-compile-out base-op tmp))) 2694 (byte-compile-out base-op tmp)))
2710 2695
2711 (defmacro byte-compile-get-constant (const) 2696 (defmacro byte-compile-get-constant (const)
2712 (` (or (if (stringp (, const)) 2697 `(or (if (stringp ,const)
2713 (assoc (, const) byte-compile-constants) 2698 (assoc ,const byte-compile-constants)
2714 (assq (, const) byte-compile-constants)) 2699 (assq ,const byte-compile-constants))
2715 (car (setq byte-compile-constants 2700 (car (setq byte-compile-constants
2716 (cons (list (, const)) byte-compile-constants)))))) 2701 (cons (list ,const) byte-compile-constants)))))
2717 2702
2718 ;; Use this when the value of a form is a constant. This obeys for-effect. 2703 ;; Use this when the value of a form is a constant. This obeys for-effect.
2719 (defun byte-compile-constant (const) 2704 (defun byte-compile-constant (const)
2720 (if for-effect 2705 (if for-effect
2721 (setq for-effect nil) 2706 (setq for-effect nil)
2892 (byte-defop-compiler (eql byte-eq) 2) 2877 (byte-defop-compiler (eql byte-eq) 2)
2893 (byte-defop-compiler20 old-eq 2) 2878 (byte-defop-compiler20 old-eq 2)
2894 (byte-defop-compiler20 old-memq 2) 2879 (byte-defop-compiler20 old-memq 2)
2895 (byte-defop-compiler cons 2) 2880 (byte-defop-compiler cons 2)
2896 (byte-defop-compiler aref 2) 2881 (byte-defop-compiler aref 2)
2897 (byte-defop-compiler (= byte-eqlsign) byte-compile-one-or-more-args)
2898 (byte-defop-compiler (< byte-lss) byte-compile-one-or-more-args)
2899 (byte-defop-compiler (> byte-gtr) byte-compile-one-or-more-args)
2900 (byte-defop-compiler (<= byte-leq) byte-compile-one-or-more-args)
2901 (byte-defop-compiler (>= byte-geq) byte-compile-one-or-more-args)
2902 (byte-defop-compiler /= byte-compile-/=)
2903 (byte-defop-compiler get 2+1) 2882 (byte-defop-compiler get 2+1)
2904 (byte-defop-compiler nth 2) 2883 (byte-defop-compiler nth 2)
2905 (byte-defop-compiler substring 2-3) 2884 (byte-defop-compiler substring 2-3)
2906 (byte-defop-compiler (move-marker byte-set-marker) 2-3) 2885 (byte-defop-compiler (move-marker byte-set-marker) 2-3)
2907 (byte-defop-compiler set-marker 2-3) 2886 (byte-defop-compiler set-marker 2-3)
2920 (byte-defop-compiler20 old-assq 2) 2899 (byte-defop-compiler20 old-assq 2)
2921 (byte-defop-compiler (rplaca byte-setcar) 2) 2900 (byte-defop-compiler (rplaca byte-setcar) 2)
2922 (byte-defop-compiler (rplacd byte-setcdr) 2) 2901 (byte-defop-compiler (rplacd byte-setcdr) 2)
2923 (byte-defop-compiler setcar 2) 2902 (byte-defop-compiler setcar 2)
2924 (byte-defop-compiler setcdr 2) 2903 (byte-defop-compiler setcdr 2)
2925 ;; buffer-substring now has its own function. This used to be
2926 ;; 2+1, but now all args are optional.
2927 (byte-defop-compiler buffer-substring)
2928 (byte-defop-compiler delete-region 2+1) 2904 (byte-defop-compiler delete-region 2+1)
2929 (byte-defop-compiler narrow-to-region 2+1) 2905 (byte-defop-compiler narrow-to-region 2+1)
2930 (byte-defop-compiler (% byte-rem) 2) 2906 (byte-defop-compiler (% byte-rem) 2)
2931 (byte-defop-compiler aset 3) 2907 (byte-defop-compiler aset 3)
2932 2908
2952 ;; former is byte-coded and the latter is not. 2928 ;; former is byte-coded and the latter is not.
2953 ;;(byte-defop-compiler (mod byte-rem) 2) 2929 ;;(byte-defop-compiler (mod byte-rem) 2)
2954 2930
2955 2931
2956 (defun byte-compile-subr-wrong-args (form n) 2932 (defun byte-compile-subr-wrong-args (form n)
2957 (byte-compile-warn "%s called with %d arg%s, but requires %s" 2933 (when (memq 'subr-callargs byte-compile-warnings)
2958 (car form) (length (cdr form)) 2934 (byte-compile-warn "%s called with %d arg%s, but requires %s"
2959 (if (= 1 (length (cdr form))) "" "s") n) 2935 (car form) (length (cdr form))
2936 (if (= 1 (length (cdr form))) "" "s") n))
2960 ;; get run-time wrong-number-of-args error. 2937 ;; get run-time wrong-number-of-args error.
2961 (byte-compile-normal-call form)) 2938 (byte-compile-normal-call form))
2962 2939
2963 (defun byte-compile-no-args (form) 2940 (defun byte-compile-no-args (form)
2964 (if (not (= (length form) 1)) 2941 (case (length (cdr form))
2965 (byte-compile-subr-wrong-args form "none") 2942 (0 (byte-compile-out (get (car form) 'byte-opcode) 0))
2966 (byte-compile-out (get (car form) 'byte-opcode) 0))) 2943 (t (byte-compile-subr-wrong-args form "none"))))
2967 2944
2968 (defun byte-compile-one-arg (form) 2945 (defun byte-compile-one-arg (form)
2969 (if (not (= (length form) 2)) 2946 (case (length (cdr form))
2970 (byte-compile-subr-wrong-args form 1) 2947 (1 (byte-compile-form (car (cdr form))) ;; Push the argument
2971 (byte-compile-form (car (cdr form))) ;; Push the argument 2948 (byte-compile-out (get (car form) 'byte-opcode) 0))
2972 (byte-compile-out (get (car form) 'byte-opcode) 0))) 2949 (t (byte-compile-subr-wrong-args form 1))))
2973 2950
2974 (defun byte-compile-two-args (form) 2951 (defun byte-compile-two-args (form)
2975 (if (not (= (length form) 3)) 2952 (case (length (cdr form))
2976 (byte-compile-subr-wrong-args form 2) 2953 (2 (byte-compile-form (nth 1 form)) ;; Push the arguments
2977 (byte-compile-form (car (cdr form))) ;; Push the arguments 2954 (byte-compile-form (nth 2 form))
2978 (byte-compile-form (nth 2 form)) 2955 (byte-compile-out (get (car form) 'byte-opcode) 0))
2979 (byte-compile-out (get (car form) 'byte-opcode) 0))) 2956 (t (byte-compile-subr-wrong-args form 2))))
2980 2957
2981 (defun byte-compile-three-args (form) 2958 (defun byte-compile-three-args (form)
2982 (if (not (= (length form) 4)) 2959 (case (length (cdr form))
2983 (byte-compile-subr-wrong-args form 3) 2960 (3 (byte-compile-form (nth 1 form)) ;; Push the arguments
2984 (byte-compile-form (car (cdr form))) ;; Push the arguments 2961 (byte-compile-form (nth 2 form))
2985 (byte-compile-form (nth 2 form)) 2962 (byte-compile-form (nth 3 form))
2986 (byte-compile-form (nth 3 form)) 2963 (byte-compile-out (get (car form) 'byte-opcode) 0))
2987 (byte-compile-out (get (car form) 'byte-opcode) 0))) 2964 (t (byte-compile-subr-wrong-args form 3))))
2988 2965
2989 (defun byte-compile-zero-or-one-arg (form) 2966 (defun byte-compile-zero-or-one-arg (form)
2990 (let ((len (length form))) 2967 (case (length (cdr form))
2991 (cond ((= len 1) (byte-compile-one-arg (append form '(nil)))) 2968 (0 (byte-compile-one-arg (append form '(nil))))
2992 ((= len 2) (byte-compile-one-arg form)) 2969 (1 (byte-compile-one-arg form))
2993 (t (byte-compile-subr-wrong-args form "0-1"))))) 2970 (t (byte-compile-subr-wrong-args form "0-1"))))
2994 2971
2995 (defun byte-compile-one-or-two-args (form) 2972 (defun byte-compile-one-or-two-args (form)
2996 (let ((len (length form))) 2973 (case (length (cdr form))
2997 (cond ((= len 2) (byte-compile-two-args (append form '(nil)))) 2974 (1 (byte-compile-two-args (append form '(nil))))
2998 ((= len 3) (byte-compile-two-args form)) 2975 (2 (byte-compile-two-args form))
2999 (t (byte-compile-subr-wrong-args form "1-2"))))) 2976 (t (byte-compile-subr-wrong-args form "1-2"))))
3000 2977
3001 (defun byte-compile-two-or-three-args (form) 2978 (defun byte-compile-two-or-three-args (form)
3002 (let ((len (length form))) 2979 (case (length (cdr form))
3003 (cond ((= len 3) (byte-compile-three-args (append form '(nil)))) 2980 (2 (byte-compile-three-args (append form '(nil))))
3004 ((= len 4) (byte-compile-three-args form)) 2981 (3 (byte-compile-three-args form))
3005 (t (byte-compile-subr-wrong-args form "2-3"))))) 2982 (t (byte-compile-subr-wrong-args form "2-3"))))
3006 2983
3007 ;; from Ben Wing <ben@xemacs.org>: some inlined functions have extra 2984 ;; from Ben Wing <ben@xemacs.org>: some inlined functions have extra
3008 ;; optional args added to them in XEmacs 19.12. Changing the byte 2985 ;; optional args added to them in XEmacs 19.12. Changing the byte
3009 ;; interpreter to deal with these args would be wrong and cause 2986 ;; interpreter to deal with these args would be wrong and cause
3010 ;; incompatibility, so we generate non-inlined calls for those cases. 2987 ;; incompatibility, so we generate non-inlined calls for those cases.
3011 ;; Without the following functions, spurious warnings will be generated; 2988 ;; Without the following functions, spurious warnings will be generated;
3012 ;; however, they would still compile correctly because 2989 ;; however, they would still compile correctly because
3013 ;; `byte-compile-subr-wrong-args' also converts the call to non-inlined. 2990 ;; `byte-compile-subr-wrong-args' also converts the call to non-inlined.
3014 2991
3015 (defun byte-compile-no-args-with-one-extra (form) 2992 (defun byte-compile-no-args-with-one-extra (form)
3016 (let ((len (length form))) 2993 (case (length (cdr form))
3017 (cond ((= len 1) (byte-compile-no-args form)) 2994 (0 (byte-compile-no-args form))
3018 ((= len 2) (byte-compile-normal-call form)) 2995 (1 (byte-compile-normal-call form))
3019 (t (byte-compile-subr-wrong-args form "0-1"))))) 2996 (t (byte-compile-subr-wrong-args form "0-1"))))
3020 2997
3021 (defun byte-compile-one-arg-with-one-extra (form) 2998 (defun byte-compile-one-arg-with-one-extra (form)
3022 (let ((len (length form))) 2999 (case (length (cdr form))
3023 (cond ((= len 2) (byte-compile-one-arg form)) 3000 (1 (byte-compile-one-arg form))
3024 ((= len 3) (byte-compile-normal-call form)) 3001 (2 (byte-compile-normal-call form))
3025 (t (byte-compile-subr-wrong-args form "1-2"))))) 3002 (t (byte-compile-subr-wrong-args form "1-2"))))
3026 3003
3027 (defun byte-compile-two-args-with-one-extra (form) 3004 (defun byte-compile-two-args-with-one-extra (form)
3028 (let ((len (length form))) 3005 (case (length (cdr form))
3029 (cond ((= len 3) (byte-compile-two-args form)) 3006 (2 (byte-compile-two-args form))
3030 ((= len 4) (byte-compile-normal-call form)) 3007 (3 (byte-compile-normal-call form))
3031 (t (byte-compile-subr-wrong-args form "2-3"))))) 3008 (t (byte-compile-subr-wrong-args form "2-3"))))
3032 3009
3033 (defun byte-compile-zero-or-one-arg-with-one-extra (form) 3010 (defun byte-compile-zero-or-one-arg-with-one-extra (form)
3034 (let ((len (length form))) 3011 (case (length (cdr form))
3035 (cond ((= len 1) (byte-compile-one-arg (append form '(nil)))) 3012 (0 (byte-compile-one-arg (append form '(nil))))
3036 ((= len 2) (byte-compile-one-arg form)) 3013 (1 (byte-compile-one-arg form))
3037 ((= len 3) (byte-compile-normal-call form)) 3014 (2 (byte-compile-normal-call form))
3038 (t (byte-compile-subr-wrong-args form "0-2"))))) 3015 (t (byte-compile-subr-wrong-args form "0-2"))))
3039 3016
3040 (defun byte-compile-one-or-two-args-with-one-extra (form) 3017 (defun byte-compile-one-or-two-args-with-one-extra (form)
3041 (let ((len (length form))) 3018 (case (length (cdr form))
3042 (cond ((= len 2) (byte-compile-two-args (append form '(nil)))) 3019 (1 (byte-compile-two-args (append form '(nil))))
3043 ((= len 3) (byte-compile-two-args form)) 3020 (2 (byte-compile-two-args form))
3044 ((= len 4) (byte-compile-normal-call form)) 3021 (3 (byte-compile-normal-call form))
3045 (t (byte-compile-subr-wrong-args form "1-3"))))) 3022 (t (byte-compile-subr-wrong-args form "1-3"))))
3046 3023
3047 (defun byte-compile-two-or-three-args-with-one-extra (form) 3024 (defun byte-compile-two-or-three-args-with-one-extra (form)
3048 (let ((len (length form))) 3025 (case (length (cdr form))
3049 (cond ((= len 3) (byte-compile-three-args (append form '(nil)))) 3026 (2 (byte-compile-three-args (append form '(nil))))
3050 ((= len 4) (byte-compile-three-args form)) 3027 (3 (byte-compile-three-args form))
3051 ((= len 5) (byte-compile-normal-call form)) 3028 (4 (byte-compile-normal-call form))
3052 (t (byte-compile-subr-wrong-args form "2-4"))))) 3029 (t (byte-compile-subr-wrong-args form "2-4"))))
3053 3030
3054 (defun byte-compile-no-args-with-two-extra (form) 3031 (defun byte-compile-no-args-with-two-extra (form)
3055 (let ((len (length form))) 3032 (case (length (cdr form))
3056 (cond ((= len 1) (byte-compile-no-args form)) 3033 (0 (byte-compile-no-args form))
3057 ((or (= len 2) (= len 3)) (byte-compile-normal-call form)) 3034 ((1 2) (byte-compile-normal-call form))
3058 (t (byte-compile-subr-wrong-args form "0-2"))))) 3035 (t (byte-compile-subr-wrong-args form "0-2"))))
3059 3036
3060 (defun byte-compile-one-arg-with-two-extra (form) 3037 (defun byte-compile-one-arg-with-two-extra (form)
3061 (let ((len (length form))) 3038 (case (length (cdr form))
3062 (cond ((= len 2) (byte-compile-one-arg form)) 3039 (1 (byte-compile-one-arg form))
3063 ((or (= len 3) (= len 4)) (byte-compile-normal-call form)) 3040 ((2 3) (byte-compile-normal-call form))
3064 (t (byte-compile-subr-wrong-args form "1-3"))))) 3041 (t (byte-compile-subr-wrong-args form "1-3"))))
3065 3042
3066 ;; XEmacs: used for functions that have a different opcode in v19 than v20. 3043 ;; XEmacs: used for functions that have a different opcode in v19 than v20.
3067 ;; this includes `eq', `equal', and other old-ified functions. 3044 ;; this includes `eq', `equal', and other old-ified functions.
3068 (defun byte-compile-two-args-19->20 (form) 3045 (defun byte-compile-two-args-19->20 (form)
3069 (if (not (= (length form) 3)) 3046 (if (not (= (length form) 3))
3078 (byte-compile-constant nil)) 3055 (byte-compile-constant nil))
3079 3056
3080 (defun byte-compile-discard () 3057 (defun byte-compile-discard ()
3081 (byte-compile-out 'byte-discard 0)) 3058 (byte-compile-out 'byte-discard 0))
3082 3059
3060 ;; Compile a function that accepts one or more args and is right-associative.
3061 ;; We do it by left-associativity so that the operations
3062 ;; are done in the same order as in interpreted code.
3063 ;(defun byte-compile-associative (form)
3064 ; (if (cdr form)
3065 ; (let ((opcode (get (car form) 'byte-opcode))
3066 ; (args (copy-sequence (cdr form))))
3067 ; (byte-compile-form (car args))
3068 ; (setq args (cdr args))
3069 ; (while args
3070 ; (byte-compile-form (car args))
3071 ; (byte-compile-out opcode 0)
3072 ; (setq args (cdr args))))
3073 ; (byte-compile-constant (eval form))))
3083 3074
3084 ;; Compile a function that accepts one or more args and is right-associative. 3075 ;; Compile a function that accepts one or more args and is right-associative.
3085 ;; We do it by left-associativity so that the operations 3076 ;; We do it by left-associativity so that the operations
3086 ;; are done in the same order as in interpreted code. 3077 ;; are done in the same order as in interpreted code.
3087 (defun byte-compile-associative (form) 3078 (defun byte-compile-associative (form)
3088 (if (cdr form) 3079 (let ((args (cdr form))
3089 (let ((opcode (get (car form) 'byte-opcode)) 3080 (opcode (get (car form) 'byte-opcode)))
3090 (args (copy-sequence (cdr form)))) 3081 (case (length args)
3091 (byte-compile-form (car args)) 3082 (0 (byte-compile-constant (eval form)))
3092 (setq args (cdr args)) 3083 (t (byte-compile-form (car args))
3093 (while args 3084 (dolist (arg (cdr args))
3094 (byte-compile-form (car args)) 3085 (byte-compile-form arg)
3095 (byte-compile-out opcode 0) 3086 (byte-compile-out opcode 0))))))
3096 (setq args (cdr args))))
3097 (byte-compile-constant (eval form))))
3098 3087
3099 3088
3100 ;; more complicated compiler macros 3089 ;; more complicated compiler macros
3101 3090
3102 (byte-defop-compiler list) 3091 (byte-defop-compiler list)
3107 (byte-defop-compiler-1 - byte-compile-minus) 3096 (byte-defop-compiler-1 - byte-compile-minus)
3108 (byte-defop-compiler (/ byte-quo) byte-compile-quo) 3097 (byte-defop-compiler (/ byte-quo) byte-compile-quo)
3109 (byte-defop-compiler nconc) 3098 (byte-defop-compiler nconc)
3110 (byte-defop-compiler-1 beginning-of-line) 3099 (byte-defop-compiler-1 beginning-of-line)
3111 3100
3112 (defun byte-compile-one-or-more-args (form) 3101 (byte-defop-compiler (= byte-eqlsign) byte-compile-arithcompare)
3113 (let ((len (length form))) 3102 (byte-defop-compiler (< byte-lss) byte-compile-arithcompare)
3114 (cond ((= len 1) (byte-compile-subr-wrong-args form "1 or more")) 3103 (byte-defop-compiler (> byte-gtr) byte-compile-arithcompare)
3115 ((= len 2) (byte-compile-constant t)) 3104 (byte-defop-compiler (<= byte-leq) byte-compile-arithcompare)
3116 ((= len 3) (byte-compile-two-args form)) 3105 (byte-defop-compiler (>= byte-geq) byte-compile-arithcompare)
3117 (t (byte-compile-normal-call form))))) 3106
3107 (defun byte-compile-arithcompare (form)
3108 (case (length (cdr form))
3109 (0 (byte-compile-subr-wrong-args form "1 or more"))
3110 (1 (byte-compile-constant t))
3111 (2 (byte-compile-two-args form))
3112 (t (byte-compile-normal-call form))))
3113
3114 (byte-defop-compiler /= byte-compile-/=)
3118 3115
3119 (defun byte-compile-/= (form) 3116 (defun byte-compile-/= (form)
3120 (let ((len (length form))) 3117 (case (length (cdr form))
3121 (cond ((= len 1) (byte-compile-subr-wrong-args form "1 or more")) 3118 (0 (byte-compile-subr-wrong-args form "1 or more"))
3122 ((= len 2) (byte-compile-constant t)) 3119 (1 (byte-compile-constant t))
3123 ;; optimize (/= X Y) to (not (= X Y)) 3120 ;; optimize (/= X Y) to (not (= X Y))
3124 ((= len 3) (byte-compile-form-do-effect `(not (= ,@(cdr form))))) 3121 (2 (byte-compile-form-do-effect `(not (= ,@(cdr form)))))
3125 (t (byte-compile-normal-call form))))) 3122 (t (byte-compile-normal-call form))))
3123
3124 ;; buffer-substring now has its own function. This used to be
3125 ;; 2+1, but now all args are optional.
3126 (byte-defop-compiler buffer-substring)
3126 3127
3127 (defun byte-compile-buffer-substring (form) 3128 (defun byte-compile-buffer-substring (form)
3128 ;; buffer-substring used to take exactly two args, but now takes 0-3. 3129 ;; buffer-substring used to take exactly two args, but now takes 0-3.
3129 ;; convert 0-2 to two args and use special bytecode operand. 3130 ;; convert 0-2 to two args and use special bytecode operand.
3130 ;; convert 3 args to a normal call. 3131 ;; convert 3 args to a normal call.
3134 (2 (byte-compile-two-args form)) 3135 (2 (byte-compile-two-args form))
3135 (3 (byte-compile-normal-call form)) 3136 (3 (byte-compile-normal-call form))
3136 (t (byte-compile-subr-wrong-args form "0-3")))) 3137 (t (byte-compile-subr-wrong-args form "0-3"))))
3137 3138
3138 (defun byte-compile-list (form) 3139 (defun byte-compile-list (form)
3139 (let ((count (length (cdr form)))) 3140 (let* ((args (cdr form))
3140 (cond ((= count 0) 3141 (nargs (length args)))
3141 (byte-compile-constant nil)) 3142 (cond
3142 ((< count 5) 3143 ((= nargs 0)
3143 (mapcar 'byte-compile-form (cdr form)) 3144 (byte-compile-constant nil))
3144 (byte-compile-out 3145 ((< nargs 5)
3145 (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0)) 3146 (mapcar 'byte-compile-form args)
3146 ((< count 256) 3147 (byte-compile-out
3147 (mapcar 'byte-compile-form (cdr form)) 3148 (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- nargs))
3148 (byte-compile-out 'byte-listN count)) 3149 0))
3149 (t (byte-compile-normal-call form))))) 3150 ((< nargs 256)
3151 (mapcar 'byte-compile-form args)
3152 (byte-compile-out 'byte-listN nargs))
3153 (t (byte-compile-normal-call form)))))
3150 3154
3151 (defun byte-compile-concat (form) 3155 (defun byte-compile-concat (form)
3152 (let ((count (length (cdr form)))) 3156 (let* ((args (cdr form))
3153 (cond ((and (< 1 count) (< count 5)) 3157 (nargs (length args)))
3154 (mapcar 'byte-compile-form (cdr form)) 3158 ;; Concat of one arg is not a no-op if arg is not a string.
3155 (byte-compile-out 3159 (cond
3156 (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2)) 3160 ((memq nargs '(2 3 4))
3157 0)) 3161 (mapcar 'byte-compile-form args)
3158 ;; Concat of one arg is not a no-op if arg is not a string. 3162 (byte-compile-out
3159 ((= count 0) 3163 (aref [byte-concat2 byte-concat3 byte-concat4] (- nargs 2))
3160 (byte-compile-form "")) 3164 0))
3161 ((< count 256) 3165 ((eq nargs 0)
3162 (mapcar 'byte-compile-form (cdr form)) 3166 (byte-compile-form ""))
3163 (byte-compile-out 'byte-concatN count)) 3167 ((< nargs 256)
3164 ((byte-compile-normal-call form))))) 3168 (mapcar 'byte-compile-form args)
3169 (byte-compile-out 'byte-concatN nargs))
3170 ((byte-compile-normal-call form)))))
3165 3171
3166 (defun byte-compile-minus (form) 3172 (defun byte-compile-minus (form)
3167 (if (null (setq form (cdr form))) 3173 (let ((args (cdr form)))
3168 (byte-compile-constant 0) 3174 (case (length args)
3169 (byte-compile-form (car form)) 3175 (0 (byte-compile-subr-wrong-args form "1 or more"))
3170 (if (cdr form) 3176 (1 (byte-compile-form (car args))
3171 (while (setq form (cdr form)) 3177 (byte-compile-out 'byte-negate 0))
3172 (byte-compile-form (car form)) 3178 (t (byte-compile-form (car args))
3173 (byte-compile-out 'byte-diff 0)) 3179 (dolist (elt (cdr args))
3174 (byte-compile-out 'byte-negate 0)))) 3180 (byte-compile-form elt)
3181 (byte-compile-out 'byte-diff 0))))))
3175 3182
3176 (defun byte-compile-quo (form) 3183 (defun byte-compile-quo (form)
3177 (let ((len (length form))) 3184 (let ((args (cdr form)))
3178 (cond ((<= len 2) 3185 (case (length args)
3179 (byte-compile-subr-wrong-args form "2 or more")) 3186 (0 (byte-compile-subr-wrong-args form "1 or more"))
3180 (t 3187 (1 (byte-compile-constant 1)
3181 (byte-compile-form (car (setq form (cdr form)))) 3188 (byte-compile-form (car args))
3182 (while (setq form (cdr form)) 3189 (byte-compile-out 'byte-quo 0))
3183 (byte-compile-form (car form)) 3190 (t (byte-compile-form (car args))
3184 (byte-compile-out 'byte-quo 0)))))) 3191 (dolist (elt (cdr args))
3192 (byte-compile-form elt)
3193 (byte-compile-out 'byte-quo 0))))))
3185 3194
3186 (defun byte-compile-nconc (form) 3195 (defun byte-compile-nconc (form)
3187 (let ((len (length form))) 3196 (let ((args (cdr form)))
3188 (cond ((= len 1) 3197 (case (length args)
3189 (byte-compile-constant nil)) 3198 (0 (byte-compile-constant nil))
3190 ((= len 2) 3199 ;; nconc of one arg is a noop, even if that arg isn't a list.
3191 ;; nconc of one arg is a noop, even if that arg isn't a list. 3200 (1 (byte-compile-form (car args)))
3192 (byte-compile-form (nth 1 form))) 3201 (t (byte-compile-form (car args))
3193 (t 3202 (dolist (elt (cdr args))
3194 (byte-compile-form (car (setq form (cdr form)))) 3203 (byte-compile-form elt)
3195 (while (setq form (cdr form)) 3204 (byte-compile-out 'byte-nconc 0))))))
3196 (byte-compile-form (car form))
3197 (byte-compile-out 'byte-nconc 0))))))
3198 3205
3199 (defun byte-compile-fset (form) 3206 (defun byte-compile-fset (form)
3200 ;; warn about forms like (fset 'foo '(lambda () ...)) 3207 ;; warn about forms like (fset 'foo '(lambda () ...))
3201 ;; (where the lambda expression is non-trivial...) 3208 ;; (where the lambda expression is non-trivial...)
3202 ;; Except don't warn if the first argument is 'make-byte-code, because 3209 ;; Except don't warn if the first argument is 'make-byte-code, because
3203 ;; I'm sick of getting mail asking me whether that warning is a problem. 3210 ;; I'm sick of getting mail asking me whether that warning is a problem.
3204 (let ((fn (nth 2 form)) 3211 (let ((fn (nth 2 form))
3205 body) 3212 body)
3206 (if (and (eq (car-safe fn) 'quote) 3213 (when (and (eq (car-safe fn) 'quote)
3207 (eq (car-safe (setq fn (nth 1 fn))) 'lambda) 3214 (eq (car-safe (setq fn (nth 1 fn))) 'lambda)
3208 (not (eq (car-safe (cdr-safe (nth 1 form))) 'make-byte-code))) 3215 (not (eq (car-safe (cdr-safe (nth 1 form))) 'make-byte-code)))
3209 (progn 3216 (setq body (cdr (cdr fn)))
3210 (setq body (cdr (cdr fn))) 3217 (if (stringp (car body)) (setq body (cdr body)))
3211 (if (stringp (car body)) (setq body (cdr body))) 3218 (if (eq 'interactive (car-safe (car body))) (setq body (cdr body)))
3212 (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) 3219 (if (and (consp (car body))
3213 (if (and (consp (car body)) 3220 (not (eq 'byte-code (car (car body)))))
3214 (not (eq 'byte-code (car (car body))))) 3221 (byte-compile-warn
3215 (byte-compile-warn 3222 "A quoted lambda form is the second argument of fset. This is probably
3216 "A quoted lambda form is the second argument of fset. This is probably
3217 not what you want, as that lambda cannot be compiled. Consider using 3223 not what you want, as that lambda cannot be compiled. Consider using
3218 the syntax (function (lambda (...) ...)) instead."))))) 3224 the syntax (function (lambda (...) ...)) instead."))))
3219 (byte-compile-two-args form)) 3225 (byte-compile-two-args form))
3220 3226
3221 (defun byte-compile-funarg (form) 3227 (defun byte-compile-funarg (form)
3222 ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..) 3228 ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..)
3223 ;; for cases where it's guaranteed that first arg will be used as a lambda. 3229 ;; for cases where it's guaranteed that first arg will be used as a lambda.
3253 ;; We can split it; there is no function call after inserting 1st arg. 3259 ;; We can split it; there is no function call after inserting 1st arg.
3254 (t 3260 (t
3255 (while (setq form (cdr form)) 3261 (while (setq form (cdr form))
3256 (byte-compile-form (car form)) 3262 (byte-compile-form (car form))
3257 (byte-compile-out 'byte-insert 0) 3263 (byte-compile-out 'byte-insert 0)
3258 (if (cdr form) 3264 (when (cdr form)
3259 (byte-compile-discard)))))) 3265 (byte-compile-discard))))))
3260 3266
3261 ;; alas, the old (pre-19.12, and all existing versions of FSFmacs 19) 3267 ;; alas, the old (pre-19.12, and all existing versions of FSFmacs 19)
3262 ;; byte compiler will generate incorrect code for 3268 ;; byte compiler will generate incorrect code for
3263 ;; (beginning-of-line nil buffer) because it buggily doesn't 3269 ;; (beginning-of-line nil buffer) because it buggily doesn't
3264 ;; check the number of arguments passed to beginning-of-line. 3270 ;; check the number of arguments passed to beginning-of-line.
3288 3294
3289 (byte-defop-compiler-1 quote) 3295 (byte-defop-compiler-1 quote)
3290 (byte-defop-compiler-1 quote-form) 3296 (byte-defop-compiler-1 quote-form)
3291 3297
3292 (defun byte-compile-setq (form) 3298 (defun byte-compile-setq (form)
3293 (let ((args (cdr form))) 3299 (let ((args (cdr form)) var val)
3294 (if args 3300 (if (null args)
3295 (while args 3301 ;; (setq), with no arguments.
3296 (byte-compile-form (car (cdr args))) 3302 (byte-compile-form nil for-effect)
3297 (or for-effect (cdr (cdr args)) 3303 (while args
3304 (setq var (pop args))
3305 (if (null args)
3306 ;; Odd number of args? Let `set' get the error.
3307 (byte-compile-form `(set ',var) for-effect)
3308 (setq val (pop args))
3309 (if (keywordp var)
3310 ;; (setq :foo ':foo) compatibility kludge
3311 (byte-compile-form `(set ',var ,val) (if args t for-effect))
3312 (byte-compile-form val)
3313 (unless (or args for-effect)
3298 (byte-compile-out 'byte-dup 0)) 3314 (byte-compile-out 'byte-dup 0))
3299 (byte-compile-variable-ref 'byte-varset (car args)) 3315 (byte-compile-variable-ref 'byte-varset var))))))
3300 (setq args (cdr (cdr args)))) 3316 (setq for-effect nil))
3301 ;; (setq), with no arguments.
3302 (byte-compile-form nil for-effect))
3303 (setq for-effect nil)))
3304 3317
3305 (defun byte-compile-set (form) 3318 (defun byte-compile-set (form)
3306 ;; Compile (set 'foo x) as (setq foo x) for trivially better code and so 3319 ;; Compile (set 'foo x) as (setq foo x) for trivially better code and so
3307 ;; that we get applicable warnings. Compile everything else (including 3320 ;; that we get applicable warnings. Compile everything else (including
3308 ;; malformed calls) like a normal 2-arg byte-coded function. 3321 ;; malformed calls) like a normal 2-arg byte-coded function.
3309 (if (or (not (eq (car-safe (nth 1 form)) 'quote)) 3322 (let ((symform (nth 1 form))
3310 (not (= (length form) 3)) 3323 (valform (nth 2 form))
3311 (not (= (length (nth 1 form)) 2))) 3324 sym)
3312 (byte-compile-two-args form) 3325 (if (and (= (length form) 3)
3313 (byte-compile-setq (list 'setq (nth 1 (nth 1 form)) (nth 2 form))))) 3326 (= (safe-length symform) 2)
3327 (eq (car symform) 'quote)
3328 (symbolp (setq sym (car (cdr symform))))
3329 (not (byte-compile-constant-symbol-p sym)))
3330 (byte-compile-setq `(setq ,sym ,valform))
3331 (byte-compile-two-args form))))
3314 3332
3315 (defun byte-compile-setq-default (form) 3333 (defun byte-compile-setq-default (form)
3316 (let ((rest (cdr form))) 3334 (let ((args (cdr form)))
3317 ;; emit multiple calls to set-default if necessary 3335 (if (null args)
3318 (while rest 3336 ;; (setq-default), with no arguments.
3319 (byte-compile-form 3337 (byte-compile-form nil for-effect)
3320 (list 'set-default (list 'quote (car rest)) (car (cdr rest))) 3338 ;; emit multiple calls to `set-default' if necessary
3321 (not (null (cdr (cdr rest))))) 3339 (while args
3322 (setq rest (cdr (cdr rest)))))) 3340 (byte-compile-form
3341 ;; Odd number of args? Let `set-default' get the error.
3342 `(set-default ',(pop args) ,@(if args (list (pop args)) nil))
3343 (if args t for-effect)))))
3344 (setq for-effect nil))
3345
3323 3346
3324 (defun byte-compile-set-default (form) 3347 (defun byte-compile-set-default (form)
3325 (let ((rest (cdr form))) 3348 (let* ((args (cdr form))
3326 (if (cdr (cdr (cdr form))) 3349 (nargs (length args))
3327 ;; emit multiple calls to set-default if necessary; all but last 3350 (var (car args)))
3328 ;; for-effect (this recurses.) 3351 (when (and (= (safe-length var) 2)
3329 (while rest 3352 (eq (car var) 'quote))
3330 (byte-compile-form 3353 (let ((sym (nth 1 var)))
3331 (list 'set-default (car rest) (car (cdr rest))) 3354 (cond
3332 (not (null (cdr rest)))) 3355 ((not (symbolp sym))
3333 (setq rest (cdr (cdr rest)))) 3356 (byte-compile-warn "Attempt to set-globally non-symbol %s" sym))
3334 ;; else, this is the one-armed version 3357 ((byte-compile-constant-symbol-p sym)
3335 (let ((var (nth 1 form)) 3358 (byte-compile-warn "Attempt to set-globally constant symbol %s" sym))
3336 ;;(val (nth 2 form)) 3359 ((let ((cell (assq sym byte-compile-bound-variables)))
3337 ) 3360 (and cell
3338 ;; notice calls to set-default/setq-default for variables which 3361 (setcdr cell (logior (cdr cell) byte-compile-assigned-bit))
3339 ;; have not been declared with defvar/defconst. 3362 t)))
3340 (if (and (memq 'free-vars byte-compile-warnings) 3363 ;; notice calls to set-default/setq-default for variables which
3341 (or (null var) 3364 ;; have not been declared with defvar/defconst.
3342 (and (eq (car-safe var) 'quote) 3365 ((globally-boundp sym)) ; OK
3343 (= 2 (length var))))) 3366 ((not (memq 'free-vars byte-compile-warnings))) ; warnings suppressed?
3344 (let ((sym (nth 1 var)) 3367 ((memq sym byte-compile-free-assignments)) ; already warned about sym
3345 cell) 3368 (t
3346 (or (and sym (symbolp sym) (globally-boundp sym)) 3369 (byte-compile-warn "assignment to free variable %s" sym)
3347 (and (setq cell (assq sym byte-compile-bound-variables)) 3370 (push sym byte-compile-free-assignments)))))
3348 (setcdr cell (logior (cdr cell) 3371 (if (= nargs 2)
3349 byte-compile-assigned-bit))) 3372 ;; now emit a normal call to set-default
3350 (memq sym byte-compile-free-assignments) 3373 (byte-compile-normal-call form)
3351 (if (or (not (symbolp sym)) (memq sym '(t nil))) 3374 (byte-compile-subr-wrong-args form 2))))
3352 (progn
3353 (byte-compile-warn
3354 "Attempt to set-globally %s %s"
3355 (if (symbolp sym) "constant" "nonvariable")
3356 (prin1-to-string sym)))
3357 (progn
3358 (byte-compile-warn "assignment to free variable %s" sym)
3359 (setq byte-compile-free-assignments
3360 (cons sym byte-compile-free-assignments)))))))
3361 ;; now emit a normal call to set-default (or possibly multiple calls)
3362 (byte-compile-normal-call form)))))
3363 3375
3364 3376
3365 (defun byte-compile-quote (form) 3377 (defun byte-compile-quote (form)
3366 (byte-compile-constant (car (cdr form)))) 3378 (byte-compile-constant (car (cdr form))))
3367 3379
3406 3418
3407 (defun byte-compile-progn (form) 3419 (defun byte-compile-progn (form)
3408 (byte-compile-body-do-effect (cdr form))) 3420 (byte-compile-body-do-effect (cdr form)))
3409 3421
3410 (defun byte-compile-prog1 (form) 3422 (defun byte-compile-prog1 (form)
3411 (byte-compile-form-do-effect (car (cdr form))) 3423 (setq form (cdr form))
3412 (byte-compile-body (cdr (cdr form)) t)) 3424 (byte-compile-form-do-effect (pop form))
3425 (byte-compile-body form t))
3413 3426
3414 (defun byte-compile-prog2 (form) 3427 (defun byte-compile-prog2 (form)
3415 (byte-compile-form (nth 1 form) t) 3428 (setq form (cdr form))
3416 (byte-compile-form-do-effect (nth 2 form)) 3429 (byte-compile-form (pop form) t)
3417 (byte-compile-body (cdr (cdr (cdr form))) t)) 3430 (byte-compile-form-do-effect (pop form))
3431 (byte-compile-body form t))
3418 3432
3419 (defmacro byte-compile-goto-if (cond discard tag) 3433 (defmacro byte-compile-goto-if (cond discard tag)
3420 (` (byte-compile-goto 3434 `(byte-compile-goto
3421 (if (, cond) 3435 (if ,cond
3422 (if (, discard) 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop) 3436 (if ,discard 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop)
3423 (if (, discard) 'byte-goto-if-nil 'byte-goto-if-nil-else-pop)) 3437 (if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop))
3424 (, tag)))) 3438 ,tag))
3425 3439
3426 (defun byte-compile-if (form) 3440 (defun byte-compile-if (form)
3427 (byte-compile-form (car (cdr form))) 3441 (byte-compile-form (car (cdr form)))
3428 (if (null (nthcdr 3 form)) 3442 (if (null (nthcdr 3 form))
3429 ;; No else-forms 3443 ;; No else-forms
3825 (defun byte-compile-make-tag () 3839 (defun byte-compile-make-tag ()
3826 (list 'TAG (setq byte-compile-tag-number (1+ byte-compile-tag-number)))) 3840 (list 'TAG (setq byte-compile-tag-number (1+ byte-compile-tag-number))))
3827 3841
3828 3842
3829 (defun byte-compile-out-tag (tag) 3843 (defun byte-compile-out-tag (tag)
3830 (setq byte-compile-output (cons tag byte-compile-output)) 3844 (push tag byte-compile-output)
3831 (if (cdr (cdr tag)) 3845 (if (cdr (cdr tag))
3832 (progn 3846 (progn
3833 ;; ## remove this someday 3847 ;; ## remove this someday
3834 (and byte-compile-depth 3848 (and byte-compile-depth
3835 (not (= (cdr (cdr tag)) byte-compile-depth)) 3849 (not (= (cdr (cdr tag)) byte-compile-depth))
3836 (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) 3850 (error "Compiler bug: depth conflict at tag %d" (car (cdr tag))))
3837 (setq byte-compile-depth (cdr (cdr tag)))) 3851 (setq byte-compile-depth (cdr (cdr tag))))
3838 (setcdr (cdr tag) byte-compile-depth))) 3852 (setcdr (cdr tag) byte-compile-depth)))
3839 3853
3840 (defun byte-compile-goto (opcode tag) 3854 (defun byte-compile-goto (opcode tag)
3841 (setq byte-compile-output (cons (cons opcode tag) byte-compile-output)) 3855 (push (cons opcode tag) byte-compile-output)
3842 (setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops) 3856 (setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops)
3843 (1- byte-compile-depth) 3857 (1- byte-compile-depth)
3844 byte-compile-depth)) 3858 byte-compile-depth))
3845 (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) 3859 (setq byte-compile-depth (and (not (eq opcode 'byte-goto))
3846 (1- byte-compile-depth)))) 3860 (1- byte-compile-depth))))
3847 3861
3848 (defun byte-compile-out (opcode offset) 3862 (defun byte-compile-out (opcode offset)
3849 (setq byte-compile-output (cons (cons opcode offset) byte-compile-output)) 3863 (push (cons opcode offset) byte-compile-output)
3850 (cond ((eq opcode 'byte-call) 3864 (case opcode
3851 (setq byte-compile-depth (- byte-compile-depth offset))) 3865 (byte-call
3852 ((eq opcode 'byte-return) 3866 (setq byte-compile-depth (- byte-compile-depth offset)))
3853 ;; This is actually an unnecessary case, because there should be 3867 (byte-return
3854 ;; no more opcodes behind byte-return. 3868 ;; This is actually an unnecessary case, because there should be
3855 (setq byte-compile-depth nil)) 3869 ;; no more opcodes behind byte-return.
3856 (t 3870 (setq byte-compile-depth nil))
3857 (setq byte-compile-depth (+ byte-compile-depth 3871 (t
3858 (or (aref byte-stack+-info 3872 (setq byte-compile-depth (+ byte-compile-depth
3859 (symbol-value opcode)) 3873 (or (aref byte-stack+-info
3860 (- (1- offset)))) 3874 (symbol-value opcode))
3861 byte-compile-maxdepth (max byte-compile-depth 3875 (- (1- offset))))
3862 byte-compile-maxdepth)))) 3876 byte-compile-maxdepth (max byte-compile-depth
3877 byte-compile-maxdepth))))
3863 ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) 3878 ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow"))
3864 ) 3879 )
3865 3880
3866 3881
3867 ;;; call tree stuff 3882 ;;; call tree stuff
3871 ;; annotate the current call 3886 ;; annotate the current call
3872 (if (setq entry (assq (car form) byte-compile-call-tree)) 3887 (if (setq entry (assq (car form) byte-compile-call-tree))
3873 (or (memq byte-compile-current-form (nth 1 entry)) ;callers 3888 (or (memq byte-compile-current-form (nth 1 entry)) ;callers
3874 (setcar (cdr entry) 3889 (setcar (cdr entry)
3875 (cons byte-compile-current-form (nth 1 entry)))) 3890 (cons byte-compile-current-form (nth 1 entry))))
3876 (setq byte-compile-call-tree 3891 (push (list (car form) (list byte-compile-current-form) nil)
3877 (cons (list (car form) (list byte-compile-current-form) nil) 3892 byte-compile-call-tree))
3878 byte-compile-call-tree)))
3879 ;; annotate the current function 3893 ;; annotate the current function
3880 (if (setq entry (assq byte-compile-current-form byte-compile-call-tree)) 3894 (if (setq entry (assq byte-compile-current-form byte-compile-call-tree))
3881 (or (memq (car form) (nth 2 entry)) ;called 3895 (or (memq (car form) (nth 2 entry)) ;called
3882 (setcar (cdr (cdr entry)) 3896 (setcar (cdr (cdr entry))
3883 (cons (car form) (nth 2 entry)))) 3897 (cons (car form) (nth 2 entry))))
3884 (setq byte-compile-call-tree 3898 (push (list byte-compile-current-form nil (list (car form)))
3885 (cons (list byte-compile-current-form nil (list (car form))) 3899 byte-compile-call-tree))))
3886 byte-compile-call-tree)))
3887 ))
3888 3900
3889 ;; Renamed from byte-compile-report-call-tree 3901 ;; Renamed from byte-compile-report-call-tree
3890 ;; to avoid interfering with completion of byte-compile-file. 3902 ;; to avoid interfering with completion of byte-compile-file.
3891 ;;;###autoload 3903 ;;;###autoload
3892 (defun display-call-tree (&optional filename) 3904 (defun display-call-tree (&optional filename)
3921 (if byte-compile-call-tree-sort 3933 (if byte-compile-call-tree-sort
3922 (setq byte-compile-call-tree 3934 (setq byte-compile-call-tree
3923 (sort byte-compile-call-tree 3935 (sort byte-compile-call-tree
3924 (cond 3936 (cond
3925 ((eq byte-compile-call-tree-sort 'callers) 3937 ((eq byte-compile-call-tree-sort 'callers)
3926 (function (lambda (x y) (< (length (nth 1 x)) 3938 #'(lambda (x y) (< (length (nth 1 x))
3927 (length (nth 1 y)))))) 3939 (length (nth 1 y)))))
3928 ((eq byte-compile-call-tree-sort 'calls) 3940 ((eq byte-compile-call-tree-sort 'calls)
3929 (function (lambda (x y) (< (length (nth 2 x)) 3941 #'(lambda (x y) (< (length (nth 2 x))
3930 (length (nth 2 y)))))) 3942 (length (nth 2 y)))))
3931 ((eq byte-compile-call-tree-sort 'calls+callers) 3943 ((eq byte-compile-call-tree-sort 'calls+callers)
3932 (function (lambda (x y) (< (+ (length (nth 1 x)) 3944 #'(lambda (x y) (< (+ (length (nth 1 x))
3933 (length (nth 2 x))) 3945 (length (nth 2 x)))
3934 (+ (length (nth 1 y)) 3946 (+ (length (nth 1 y))
3935 (length (nth 2 y))))))) 3947 (length (nth 2 y))))))
3936 ((eq byte-compile-call-tree-sort 'name) 3948 ((eq byte-compile-call-tree-sort 'name)
3937 (function (lambda (x y) (string< (car x) 3949 #'(lambda (x y) (string< (car x)
3938 (car y))))) 3950 (car y))))
3939 (t (error 3951 (t (error
3940 "`byte-compile-call-tree-sort': `%s' - unknown sort mode" 3952 "`byte-compile-call-tree-sort': `%s' - unknown sort mode"
3941 byte-compile-call-tree-sort)))))) 3953 byte-compile-call-tree-sort))))))
3942 (message "Generating call tree...") 3954 (message "Generating call tree...")
3943 (let ((rest byte-compile-call-tree) 3955 (let ((rest byte-compile-call-tree)
4029 ;; command-line-args-left is what is left of the command line (from 4041 ;; command-line-args-left is what is left of the command line (from
4030 ;; startup.el) 4042 ;; startup.el)
4031 (defvar command-line-args-left) ;Avoid 'free variable' warning 4043 (defvar command-line-args-left) ;Avoid 'free variable' warning
4032 (if (not noninteractive) 4044 (if (not noninteractive)
4033 (error "`batch-byte-compile' is to be used only with -batch")) 4045 (error "`batch-byte-compile' is to be used only with -batch"))
4034 (let ((error nil) 4046 (let ((error nil))
4035 (debug-issue-ebola-notices 0)) ; Hack -slb
4036 (while command-line-args-left 4047 (while command-line-args-left
4037 (if (file-directory-p (expand-file-name (car command-line-args-left))) 4048 (if (file-directory-p (expand-file-name (car command-line-args-left)))
4038 (let ((files (directory-files (car command-line-args-left))) 4049 (let ((files (directory-files (car command-line-args-left)))
4039 source dest) 4050 source dest)
4040 (while files 4051 (while files
4063 (princ file) 4074 (princ file)
4064 (princ ": ") 4075 (princ ": ")
4065 (if (fboundp 'display-error) ; XEmacs 19.8+ 4076 (if (fboundp 'display-error) ; XEmacs 19.8+
4066 (display-error err nil) 4077 (display-error err nil)
4067 (princ (or (get (car err) 'error-message) (car err))) 4078 (princ (or (get (car err) 'error-message) (car err)))
4068 (mapcar '(lambda (x) (princ " ") (prin1 x)) (cdr err))) 4079 (mapcar #'(lambda (x) (princ " ") (prin1 x)) (cdr err)))
4069 (princ "\n") 4080 (princ "\n")
4070 nil))) 4081 nil)))
4071 4082
4072 ;;;###autoload 4083 ;;;###autoload
4073 (defun batch-byte-recompile-directory-norecurse () 4084 (defun batch-byte-recompile-directory-norecurse ()
4084 (defvar command-line-args-left) ;Avoid 'free variable' warning 4095 (defvar command-line-args-left) ;Avoid 'free variable' warning
4085 (if (not noninteractive) 4096 (if (not noninteractive)
4086 (error "batch-byte-recompile-directory is to be used only with -batch")) 4097 (error "batch-byte-recompile-directory is to be used only with -batch"))
4087 (or command-line-args-left 4098 (or command-line-args-left
4088 (setq command-line-args-left '("."))) 4099 (setq command-line-args-left '(".")))
4089 (let ((byte-recompile-directory-ignore-errors-p t) 4100 (let ((byte-recompile-directory-ignore-errors-p t))
4090 (debug-issue-ebola-notices 0))
4091 (while command-line-args-left 4101 (while command-line-args-left
4092 (byte-recompile-directory (car command-line-args-left)) 4102 (byte-recompile-directory (car command-line-args-left))
4093 (setq command-line-args-left (cdr command-line-args-left)))) 4103 (setq command-line-args-left (cdr command-line-args-left))))
4094 (kill-emacs 0)) 4104 (kill-emacs 0))
4095 4105
4138 (eval-when-compile 4148 (eval-when-compile
4139 (or (compiled-function-p (symbol-function 'byte-compile-form)) 4149 (or (compiled-function-p (symbol-function 'byte-compile-form))
4140 (assq 'byte-code (symbol-function 'byte-compile-form)) 4150 (assq 'byte-code (symbol-function 'byte-compile-form))
4141 (let ((byte-optimize nil) ; do it fast 4151 (let ((byte-optimize nil) ; do it fast
4142 (byte-compile-warnings nil)) 4152 (byte-compile-warnings nil))
4143 (mapcar '(lambda (x) 4153 (mapcar #'(lambda (x)
4144 (or noninteractive (message "compiling %s..." x)) 4154 (or noninteractive (message "compiling %s..." x))
4145 (byte-compile x) 4155 (byte-compile x)
4146 (or noninteractive (message "compiling %s...done" x))) 4156 (or noninteractive (message "compiling %s...done" x)))
4147 '(byte-compile-normal-call 4157 '(byte-compile-normal-call
4148 byte-compile-form 4158 byte-compile-form
4149 byte-compile-body 4159 byte-compile-body
4150 ;; Inserted some more than necessary, to speed it up. 4160 ;; Inserted some more than necessary, to speed it up.
4151 byte-compile-top-level 4161 byte-compile-top-level