Mercurial > hg > xemacs-beta
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 |