Mercurial > hg > xemacs-beta

comparison lisp/bytecomp/bytecomp.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 8fc7fe29b841
children dbb370e3c29e
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; bytecomp.el --- compilation of Lisp code into byte code. 1 ;;; bytecomp.el --- compilation of Lisp code into byte code.
2 2
3 ;;; Copyright (C) 1985-1987, 1991-1994 Free Software Foundation, Inc. 3 ;;; Copyright (C) 1985-1987, 1991-1994 Free Software Foundation, Inc.
4 4 ;;; Copyright (C) 1996 Ben Wing.
5 ;; Author: Jamie Zawinski <jwz@netscape.com> 5
6 ;; Author: Jamie Zawinski <jwz@lucid.com>
6 ;; Hallvard Furuseth <hbf@ulrik.uio.no> 7 ;; Hallvard Furuseth <hbf@ulrik.uio.no>
7 ;; Keywords: internal 8 ;; Keywords: internal
8 9
9 ;; Subsequently modified by RMS and others. 10 ;; Subsequently modified by RMS and others.
10 11
11 (defconst byte-compile-version (purecopy "2.25; 1-Sep-94.")) 12 (defconst byte-compile-version (purecopy "2.25 XEmacs; 22-Mar-96."))
12 13
13 ;; This file is part of XEmacs. 14 ;; This file is part of XEmacs.
14 15
15 ;; 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
16 ;; 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
101 ;;; match the lambda's definition) 102 ;;; match the lambda's definition)
102 ;;; 'redefine (function cell redefined from 103 ;;; 'redefine (function cell redefined from
103 ;;; a macro to a lambda or vice versa, 104 ;;; a macro to a lambda or vice versa,
104 ;;; or redefined to take other args) 105 ;;; or redefined to take other args)
105 ;;; 'obsolete (obsolete variables and functions) 106 ;;; 'obsolete (obsolete variables and functions)
106 ;;; 'pedantic (references to Emacs-compatible 107 ;;; byte-compile-emacs19-compatibility Whether the compiler should
107 ;;; symbols)
108 ;;; (RMS calls the following option byte-compile-compatibility but
109 ;;; our name is better)
110 ;;; byte-compile-emacs18-compatibility Whether the compiler should
111 ;;; generate .elc files which can be loaded into 108 ;;; generate .elc files which can be loaded into
112 ;;; generic emacs 18. 109 ;;; generic emacs 19.
113 ;;; emacs-lisp-file-regexp Regexp for the extension of source-files; 110 ;;; emacs-lisp-file-regexp Regexp for the extension of source-files;
114 ;;; see also the function byte-compile-dest-file. 111 ;;; see also the function byte-compile-dest-file.
115 ;;; byte-compile-overwrite-file If nil, delete old .elc files before saving. 112 ;;; byte-compile-overwrite-file If nil, delete old .elc files before saving.
116 ;;; 113 ;;;
117 ;;; Most of the above parameters can also be set on a file-by-file basis; see 114 ;;; Most of the above parameters can also be set on a file-by-file basis; see
194 ;;; o If the optimizer deletes a variable reference, we might be left with 191 ;;; o If the optimizer deletes a variable reference, we might be left with
195 ;;; a bound-but-not-referenced warning. Generally this is ok, but not if 192 ;;; a bound-but-not-referenced warning. Generally this is ok, but not if
196 ;;; it's a synergistic result of macroexpansion. Need some way to note 193 ;;; it's a synergistic result of macroexpansion. Need some way to note
197 ;;; that a varref is being optimized away? Of course it would be nice to 194 ;;; that a varref is being optimized away? Of course it would be nice to
198 ;;; optimize away the binding too, someday, but it's unsafe today. 195 ;;; optimize away the binding too, someday, but it's unsafe today.
199 ;;; o Is it time to finally delete all of that egregious v18 compatibility
200 ;;; code yet?
201 ;;; o (See byte-optimize.el for the optimization TODO list.) 196 ;;; o (See byte-optimize.el for the optimization TODO list.)
202 197
203 (require 'backquote) 198 (require 'backquote)
204 199
205 (or (fboundp 'defsubst) 200 (or (fboundp 'defsubst)
206 ;; This really ought to be loaded already! 201 ;; This really ought to be loaded already!
207 (load-library "bytecomp-runtime")) 202 (load-library "bytecomp-runtime"))
208 203
209 (eval-when-compile 204 (eval-when-compile
210 (defvar byte-compile-single-version nil 205 (defvar byte-compile-single-version nil
211 "If this is true, the choice of emacs version (v18 or v19) byte-codes will 206 "If this is true, the choice of emacs version (v19 or v20) byte-codes will
212 be hard-coded into bytecomp when it compiles itself. If the compiler itself 207 be hard-coded into bytecomp when it compiles itself. If the compiler itself
213 is compiled with optimization, this causes a speedup.") 208 is compiled with optimization, this causes a speedup.")
214 209
215 (cond (byte-compile-single-version 210 (cond (byte-compile-single-version
216 (defmacro byte-compile-single-version () t) 211 (defmacro byte-compile-single-version () t)
217 (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond)))) 212 (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond))))
218 (t 213 (t
219 (defmacro byte-compile-single-version () nil) 214 (defmacro byte-compile-single-version () nil)
220 (defmacro byte-compile-version-cond (cond) cond))) 215 (defmacro byte-compile-version-cond (cond) cond)))
221 ) 216 )
222
223 ;;; The crud you see scattered through this file of the form
224 ;;; (or (and (boundp 'epoch::version) epoch::version)
225 ;;; (string-lessp emacs-version "19"))
226 ;;; is because the Epoch folks couldn't be bothered to follow the
227 ;;; normal emacs version numbering convention.
228
229 217
230 (defvar emacs-lisp-file-regexp (if (eq system-type 'vax-vms) 218 (defvar emacs-lisp-file-regexp (if (eq system-type 'vax-vms)
231 (purecopy "\\.EL\\(;[0-9]+\\)?$") 219 (purecopy "\\.EL\\(;[0-9]+\\)?$")
232 (purecopy "\\.el$")) 220 (purecopy "\\.el$"))
233 "*Regexp which matches Emacs Lisp source files. 221 "*Regexp which matches Emacs Lisp source files.
273 261
274 (defvar byte-compile-verbose 262 (defvar byte-compile-verbose
275 (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) 263 (and (not noninteractive) (> (device-baud-rate) search-slow-speed))
276 "*Non-nil means print messages describing progress of byte-compiler.") 264 "*Non-nil means print messages describing progress of byte-compiler.")
277 265
278 (defvar byte-compile-emacs18-compatibility nil 266 (defvar byte-compile-emacs19-compatibility
279 "*Non-nil means generate output that can run in Emacs 18.") 267 (not (emacs-version>= 20))
268 "*Non-nil means generate output that can run in Emacs 19.")
280 269
281 (defvar byte-optimize t 270 (defvar byte-optimize t
282 "*Enables optimization in the byte compiler. 271 "*Enables optimization in the byte compiler.
283 nil means don't do any optimization. 272 nil means don't do any optimization.
284 t means do all optimizations. 273 t means do all optimizations.
299 ;; by default. This would be a reasonable conservative approach except 288 ;; by default. This would be a reasonable conservative approach except
300 ;; for the fact that if you enable either of these, you get incompatible 289 ;; for the fact that if you enable either of these, you get incompatible
301 ;; byte code that can't be read by XEmacs 19.13 or before or FSF 19.28 or 290 ;; byte code that can't be read by XEmacs 19.13 or before or FSF 19.28 or
302 ;; before. 291 ;; before.
303 ;; 292 ;;
304 ;; Therefore, neither is enabled for 19.14. 293 ;; Therefore, neither is enabled for 19.14. Both are enabled for 20.0
294 ;; because we have no reason to be conservative about changing the
295 ;; way things work. (Ben)
296
297 ;; However, I don't think that defaulting byte-compile-dynamic to nil
298 ;; is a compatibility issue - rather it is a performance issue.
299 ;; Therefore I am setting byte-compile-dynamic back to nil. (mrb)
305 300
306 (defvar byte-compile-dynamic nil 301 (defvar byte-compile-dynamic nil
307 "*If non-nil, compile function bodies so they load lazily. 302 "*If non-nil, compile function bodies so they load lazily.
308 They are hidden comments in the compiled file, and brought into core when the 303 They are hidden comments in the compiled file, and brought into core when the
309 function is called. 304 function is called.
313 For example, add -*-byte-compile-dynamic: t;-*- on the first line. 308 For example, add -*-byte-compile-dynamic: t;-*- on the first line.
314 309
315 When this option is true, if you load the compiled file and then move it, 310 When this option is true, if you load the compiled file and then move it,
316 the functions you loaded will not be able to run.") 311 the functions you loaded will not be able to run.")
317 312
318 (defvar byte-compile-dynamic-docstrings nil 313 (defvar byte-compile-dynamic-docstrings (emacs-version>= 20)
319 "*If non-nil, compile doc strings for lazy access. 314 "*If non-nil, compile doc strings for lazy access.
320 We bury the doc strings of functions and variables 315 We bury the doc strings of functions and variables
321 inside comments in the file, and bring them into core only when they 316 inside comments in the file, and bring them into core only when they
322 are actually needed. 317 are actually needed.
323 318
353 unresolved calls to unknown functions. 348 unresolved calls to unknown functions.
354 callargs lambda calls with args that don't match the definition. 349 callargs lambda calls with args that don't match the definition.
355 redefine function cell redefined from a macro to a lambda or vice 350 redefine function cell redefined from a macro to a lambda or vice
356 versa, or redefined to take a different number of arguments. 351 versa, or redefined to take a different number of arguments.
357 obsolete use of an obsolete function or variable. 352 obsolete use of an obsolete function or variable.
358 pedantic warn of use of compatible symbols.
359 353
360 The default set is specified by `byte-compile-default-warnings' and 354 The default set is specified by `byte-compile-default-warnings' and
361 normally encompasses all possible warnings. 355 normally encompasses all possible warnings.
362 356
363 See also the macro `byte-compiler-options'.") 357 See also the macro `byte-compiler-options'.")
502 (defmacro byte-extrude-byte-code-vectors () 496 (defmacro byte-extrude-byte-code-vectors ()
503 (prog1 (list 'setq 'byte-code-vector 497 (prog1 (list 'setq 'byte-code-vector
504 (get 'byte-code-vector 'tmp-compile-time-value) 498 (get 'byte-code-vector 'tmp-compile-time-value)
505 'byte-stack+-info 499 'byte-stack+-info
506 (get 'byte-stack+-info 'tmp-compile-time-value)) 500 (get 'byte-stack+-info 'tmp-compile-time-value))
507 ;; emacs-18 has no REMPROP. 501 (remprop 'byte-code-vector 'tmp-compile-time-value)
508 (put 'byte-code-vector 'tmp-compile-time-value nil) 502 (remprop 'byte-stack+-info 'tmp-compile-time-value)))
509 (put 'byte-stack+-info 'tmp-compile-time-value nil)))
510 503
511 504
512 ;; unused: 0-7 505 ;; unused: 0-7
513 506
514 ;; These opcodes are special in that they pack their argument into the 507 ;; These opcodes are special in that they pack their argument into the
526 (byte-defop 56 -1 byte-nth) 519 (byte-defop 56 -1 byte-nth)
527 (byte-defop 57 0 byte-symbolp) 520 (byte-defop 57 0 byte-symbolp)
528 (byte-defop 58 0 byte-consp) 521 (byte-defop 58 0 byte-consp)
529 (byte-defop 59 0 byte-stringp) 522 (byte-defop 59 0 byte-stringp)
530 (byte-defop 60 0 byte-listp) 523 (byte-defop 60 0 byte-listp)
531 (byte-defop 61 -1 byte-eq) 524 (byte-defop 61 -1 byte-old-eq)
532 (byte-defop 62 -1 byte-memq) 525 (byte-defop 62 -1 byte-old-memq)
533 (byte-defop 63 0 byte-not) 526 (byte-defop 63 0 byte-not)
534 (byte-defop 64 0 byte-car) 527 (byte-defop 64 0 byte-car)
535 (byte-defop 65 0 byte-cdr) 528 (byte-defop 65 0 byte-cdr)
536 (byte-defop 66 -1 byte-cons) 529 (byte-defop 66 -1 byte-cons)
537 (byte-defop 67 0 byte-list1) 530 (byte-defop 67 0 byte-list1)
560 (byte-defop 90 -1 byte-diff) 553 (byte-defop 90 -1 byte-diff)
561 (byte-defop 91 0 byte-negate) 554 (byte-defop 91 0 byte-negate)
562 (byte-defop 92 -1 byte-plus) 555 (byte-defop 92 -1 byte-plus)
563 (byte-defop 93 -1 byte-max) 556 (byte-defop 93 -1 byte-max)
564 (byte-defop 94 -1 byte-min) 557 (byte-defop 94 -1 byte-min)
565 (byte-defop 95 -1 byte-mult) ; v19 only 558 (byte-defop 95 -1 byte-mult)
566 (byte-defop 96 1 byte-point) 559 (byte-defop 96 1 byte-point)
567 (byte-defop 97 1 byte-mark-OBSOLETE) ; no longer generated as of v18 560 (byte-defop 97 -1 byte-eq) ; new as of v20
568 (byte-defop 98 0 byte-goto-char) 561 (byte-defop 98 0 byte-goto-char)
569 (byte-defop 99 0 byte-insert) 562 (byte-defop 99 0 byte-insert)
570 (byte-defop 100 1 byte-point-max) 563 (byte-defop 100 1 byte-point-max)
571 (byte-defop 101 1 byte-point-min) 564 (byte-defop 101 1 byte-point-min)
572 (byte-defop 102 0 byte-char-after) 565 (byte-defop 102 0 byte-char-after)
573 (byte-defop 103 1 byte-following-char) 566 (byte-defop 103 1 byte-following-char)
574 (byte-defop 104 1 byte-preceding-char) 567 (byte-defop 104 1 byte-preceding-char)
575 (byte-defop 105 1 byte-current-column) 568 (byte-defop 105 1 byte-current-column)
576 (byte-defop 106 0 byte-indent-to) 569 (byte-defop 106 0 byte-indent-to)
577 (byte-defop 107 0 byte-scan-buffer-OBSOLETE) ; no longer generated as of v18 570 (byte-defop 107 -1 byte-equal) ; new as of v20
578 (byte-defop 108 1 byte-eolp) 571 (byte-defop 108 1 byte-eolp)
579 (byte-defop 109 1 byte-eobp) 572 (byte-defop 109 1 byte-eobp)
580 (byte-defop 110 1 byte-bolp) 573 (byte-defop 110 1 byte-bolp)
581 (byte-defop 111 1 byte-bobp) 574 (byte-defop 111 1 byte-bobp)
582 (byte-defop 112 1 byte-current-buffer) 575 (byte-defop 112 1 byte-current-buffer)
583 (byte-defop 113 0 byte-set-buffer) 576 (byte-defop 113 0 byte-set-buffer)
584 (byte-defop 114 1 byte-read-char-OBSOLETE) 577 (byte-defop 114 1 byte-read-char-OBSOLETE) ;obsolete as of v19
585 (byte-defop 115 0 byte-set-mark-OBSOLETE) 578 (byte-defop 115 -1 byte-memq) ; new as of v20
586 (byte-defop 116 1 byte-interactive-p) 579 (byte-defop 116 1 byte-interactive-p)
587 580
588 ;; These ops are new to v19
589 (byte-defop 117 0 byte-forward-char) 581 (byte-defop 117 0 byte-forward-char)
590 (byte-defop 118 0 byte-forward-word) 582 (byte-defop 118 0 byte-forward-word)
591 (byte-defop 119 -1 byte-skip-chars-forward) 583 (byte-defop 119 -1 byte-skip-chars-forward)
592 (byte-defop 120 -1 byte-skip-chars-backward) 584 (byte-defop 120 -1 byte-skip-chars-backward)
593 (byte-defop 121 0 byte-forward-line) 585 (byte-defop 121 0 byte-forward-line)
643 ;; Expects the temp buffer on the stack underneath value to return. 635 ;; Expects the temp buffer on the stack underneath value to return.
644 ;; Pops them both, then pushes the value back on. 636 ;; Pops them both, then pushes the value back on.
645 ;; Unbinds standard-output and makes the temp buffer visible. 637 ;; Unbinds standard-output and makes the temp buffer visible.
646 (byte-defop 145 -1 byte-temp-output-buffer-show) 638 (byte-defop 145 -1 byte-temp-output-buffer-show)
647 639
648 ;; these ops are new to v19
649
650 ;; To unbind back to the beginning of this frame. 640 ;; To unbind back to the beginning of this frame.
651 ;; Not used yet, but will be needed for tail-recursion elimination. 641 ;; Not used yet, but will be needed for tail-recursion elimination.
652 (byte-defop 146 0 byte-unbind-all) 642 (byte-defop 146 0 byte-unbind-all)
653 643
654 ;; these ops are new to v19
655 (byte-defop 147 -2 byte-set-marker) 644 (byte-defop 147 -2 byte-set-marker)
656 (byte-defop 148 0 byte-match-beginning) 645 (byte-defop 148 0 byte-match-beginning)
657 (byte-defop 149 0 byte-match-end) 646 (byte-defop 149 0 byte-match-end)
658 (byte-defop 150 0 byte-upcase) 647 (byte-defop 150 0 byte-upcase)
659 (byte-defop 151 0 byte-downcase) 648 (byte-defop 151 0 byte-downcase)
660 (byte-defop 152 -1 byte-string=) 649 (byte-defop 152 -1 byte-string=)
661 (byte-defop 153 -1 byte-string<) 650 (byte-defop 153 -1 byte-string<)
662 (byte-defop 154 -1 byte-equal) 651 (byte-defop 154 -1 byte-old-equal)
663 (byte-defop 155 -1 byte-nthcdr) 652 (byte-defop 155 -1 byte-nthcdr)
664 (byte-defop 156 -1 byte-elt) 653 (byte-defop 156 -1 byte-elt)
665 (byte-defop 157 -1 byte-member) 654 (byte-defop 157 -1 byte-old-member)
666 (byte-defop 158 -1 byte-assq) 655 (byte-defop 158 -1 byte-old-assq)
667 (byte-defop 159 0 byte-nreverse) 656 (byte-defop 159 0 byte-nreverse)
668 (byte-defop 160 -1 byte-setcar) 657 (byte-defop 160 -1 byte-setcar)
669 (byte-defop 161 -1 byte-setcdr) 658 (byte-defop 161 -1 byte-setcdr)
670 (byte-defop 162 0 byte-car-safe) 659 (byte-defop 162 0 byte-car-safe)
671 (byte-defop 163 0 byte-cdr-safe) 660 (byte-defop 163 0 byte-cdr-safe)
677 666
678 ;; unused: 169 667 ;; unused: 169
679 668
680 ;; These are not present in FSF. 669 ;; These are not present in FSF.
681 ;; 670 ;;
682 ;; New to v19. These store their arg in the next byte.
683 (byte-defop 170 0 byte-rel-goto) 671 (byte-defop 170 0 byte-rel-goto)
684 (byte-defop 171 -1 byte-rel-goto-if-nil) 672 (byte-defop 171 -1 byte-rel-goto-if-nil)
685 (byte-defop 172 -1 byte-rel-goto-if-not-nil) 673 (byte-defop 172 -1 byte-rel-goto-if-not-nil)
686 (byte-defop 173 -1 byte-rel-goto-if-nil-else-pop) 674 (byte-defop 173 -1 byte-rel-goto-if-nil-else-pop)
687 (byte-defop 174 -1 byte-rel-goto-if-not-nil-else-pop) 675 (byte-defop 174 -1 byte-rel-goto-if-not-nil-else-pop)
688 676
689 (byte-defop 175 nil byte-listN) 677 (byte-defop 175 nil byte-listN)
690 (byte-defop 176 nil byte-concatN) 678 (byte-defop 176 nil byte-concatN)
691 (byte-defop 177 nil byte-insertN) 679 (byte-defop 177 nil byte-insertN)
692 680
693 ;; unused: 178-191 681 ;; unused: 178-181
682
683 ;; these ops are new to v20
684 (byte-defop 182 -1 byte-member)
685 (byte-defop 183 -1 byte-assq)
686
687 ;; unused: 184-191
694 688
695 (byte-defop 192 1 byte-constant "for reference to a constant") 689 (byte-defop 192 1 byte-constant "for reference to a constant")
696 ;; codes 193-255 are consumed by byte-constant. 690 ;; codes 193-255 are consumed by byte-constant.
697 (defconst byte-constant-limit 64 691 (defconst byte-constant-limit 64
698 "Exclusive maximum index usable in the `byte-constant' opcode.") 692 "Exclusive maximum index usable in the `byte-constant' opcode.")
778 (t 772 (t
779 (setq pc (+ 3 pc)) 773 (setq pc (+ 3 pc))
780 (cons (lsh off -8) 774 (cons (lsh off -8)
781 (cons (logand off 255) 775 (cons (logand off 255)
782 (cons byte-constant2 bytes)))))) 776 (cons byte-constant2 bytes))))))
783 ((<= byte-listN (symbol-value op)) 777 ((and (<= byte-listN (symbol-value op))
778 (<= (symbol-value op) byte-insertN))
784 (setq pc (+ 2 pc)) 779 (setq pc (+ 2 pc))
785 (cons off (cons (symbol-value op) bytes))) 780 (cons off (cons (symbol-value op) bytes)))
786 ((< off 6) 781 ((< off 6)
787 (setq pc (1+ pc)) 782 (setq pc (1+ pc))
788 (cons (+ (symbol-value op) off) bytes)) 783 (cons (+ (symbol-value op) off) bytes))
796 (cons (+ (symbol-value op) 7) 791 (cons (+ (symbol-value op) 7)
797 bytes)))))))) 792 bytes))))))))
798 (setq lap (cdr lap))) 793 (setq lap (cdr lap)))
799 ;;(if (not (= pc (length bytes))) 794 ;;(if (not (= pc (length bytes)))
800 ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) 795 ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes)))
801 (cond ((not (byte-compile-version-cond byte-compile-emacs18-compatibility)) 796 (cond (t ;; starting with Emacs 19.
802 ;; Make relative jumps 797 ;; Make relative jumps
803 (setq patchlist (nreverse patchlist)) 798 (setq patchlist (nreverse patchlist))
804 (while (progn 799 (while (progn
805 (setq off 0) ; PC change because of deleted bytes 800 (setq off 0) ; PC change because of deleted bytes
806 (setq rest patchlist) 801 (setq rest patchlist)
952 (byte-compile-warn "%s is an obsolete function; %s" (car form) 947 (byte-compile-warn "%s is an obsolete function; %s" (car form)
953 (if (stringp (car new)) 948 (if (stringp (car new))
954 (car new) 949 (car new)
955 (format "use %s instead." (car new))))) 950 (format "use %s instead." (car new)))))
956 (funcall (or (cdr new) 'byte-compile-normal-call) form))) 951 (funcall (or (cdr new) 'byte-compile-normal-call) form)))
957
958 ;;; Used by make-obsolete.
959 (defun byte-compile-compatible (form)
960 (let ((new (get (car form) 'byte-compatible-info)))
961 (if (memq 'pedantic byte-compile-warnings)
962 (byte-compile-warn "%s is provided for compatibility; %s" (car form)
963 (if (stringp (car new))
964 (car new)
965 (format "use %s instead." (car new)))))
966 (funcall (or (cdr new) 'byte-compile-normal-call) form)))
967 952
968 ;; Compiler options 953 ;; Compiler options
969 954
970 (defconst byte-compiler-legal-options 955 (defconst byte-compiler-legal-options
971 '((optimize byte-optimize (t nil source byte) val) 956 '((optimize byte-optimize (t nil source byte) val)
972 (file-format byte-compile-emacs18-compatibility (emacs18 emacs19) 957 (file-format byte-compile-emacs19-compatibility (emacs19 emacs20)
973 (eq val 'emacs18)) 958 (eq val 'emacs19))
974 (delete-errors byte-compile-delete-errors (t nil) val) 959 (delete-errors byte-compile-delete-errors (t nil) val)
975 (verbose byte-compile-verbose (t nil) val) 960 (verbose byte-compile-verbose (t nil) val)
976 (new-bytecodes byte-compile-new-bytecodes (t nil) val) 961 (new-bytecodes byte-compile-new-bytecodes (t nil) val)
977 (warnings byte-compile-warnings 962 (warnings byte-compile-warnings
978 ((callargs redefine free-vars unused-vars unresolved)) 963 ((callargs redefine free-vars unused-vars unresolved))
980 965
981 ;; XEmacs addition 966 ;; XEmacs addition
982 (defconst byte-compiler-obsolete-options 967 (defconst byte-compiler-obsolete-options
983 '((new-bytecodes t))) 968 '((new-bytecodes t)))
984 969
985 ;; Inhibit v18/v19 selectors if the version is hardcoded. 970 ;; Inhibit v19/v20 selectors if the version is hardcoded.
986 ;; #### This should print a warning if the user tries to change something 971 ;; #### This should print a warning if the user tries to change something
987 ;; than can't be changed because the running compiler doesn't support it. 972 ;; than can't be changed because the running compiler doesn't support it.
988 (cond 973 (cond
989 ((byte-compile-single-version) 974 ((byte-compile-single-version)
990 (setcar (cdr (cdr (assq 'file-format byte-compiler-legal-options))) 975 (setcar (cdr (cdr (assq 'file-format byte-compiler-legal-options)))
991 (if (byte-compile-version-cond byte-compile-emacs18-compatibility) 976 (if (byte-compile-version-cond byte-compile-emacs19-compatibility)
992 '(emacs18) '(emacs19))))) 977 '(emacs19) '(emacs20)))))
993 978
994 ;; now we can copy it. 979 ;; now we can copy it.
995 (setq byte-compiler-legal-options (purecopy byte-compiler-legal-options)) 980 (setq byte-compiler-legal-options (purecopy byte-compiler-legal-options))
996 981
997 (defun byte-compiler-options-handler (&rest args) 982 (defun byte-compiler-options-handler (&rest args)
1237 ;; that is, variables from the lexical scope that is now 1222 ;; that is, variables from the lexical scope that is now
1238 ;; terminating. (Think nested lets.) 1223 ;; terminating. (Think nested lets.)
1239 (not (eq (car rest) 'new-scope))) 1224 (not (eq (car rest) 'new-scope)))
1240 (setq cell (car rest)) 1225 (setq cell (car rest))
1241 (if (and (= 0 (logand byte-compile-referenced-bit (cdr cell))) 1226 (if (and (= 0 (logand byte-compile-referenced-bit (cdr cell)))
1242 ;; Don't warn about declared-but-unused arguments, 1227 ;; Don't warn about declared-but-unused arguments, for two
1243 ;; for two reasons: first, the arglist structure 1228 ;; reasons: first, the arglist structure might be imposed by
1244 ;; might be imposed by external forces, and we don't 1229 ;; external forces, and we don't have (declare (ignore x)) yet;
1245 ;; have (declare (ignore x)) yet; and second, inline 1230 ;; and second, inline expansion produces forms like
1246 ;; expansion produces forms like
1247 ;; ((lambda (arg) (byte-code "..." [arg])) x) 1231 ;; ((lambda (arg) (byte-code "..." [arg])) x)
1248 ;; which we can't (ok, well, don't) recognise as 1232 ;; which we can't (ok, well, don't) recognise as containing a
1249 ;; containing a reference to arg, so every inline 1233 ;; reference to arg, so every inline expansion would generate
1250 ;; expansion would generate a warning. (If we had 1234 ;; a warning. (If we had `ignore' then inline expansion could
1251 ;; `ignore' then inline expansion could emit an 1235 ;; emit an ignore declaration.)
1252 ;; ignore declaration.)
1253 (= 0 (logand byte-compile-arglist-bit (cdr cell))) 1236 (= 0 (logand byte-compile-arglist-bit (cdr cell)))
1254 ;; Don't warn about defvars because this is a 1237 ;; Don't warn about defvars because this is a legitimate special
1255 ;; legitimate special binding. 1238 ;; binding.
1256 (not (byte-compile-defvar-p (car cell)))) 1239 (not (byte-compile-defvar-p (car cell))))
1257 (setq unreferenced (cons (car cell) unreferenced))) 1240 (setq unreferenced (cons (car cell) unreferenced)))
1258 (setq rest (cdr rest))) 1241 (setq rest (cdr rest)))
1259 (setq unreferenced (nreverse unreferenced)) 1242 (setq unreferenced (nreverse unreferenced))
1260 (while unreferenced 1243 (while unreferenced
1290 ;; Close over these variables so that `byte-compiler-options' 1273 ;; Close over these variables so that `byte-compiler-options'
1291 ;; can change them on a per-file basis. 1274 ;; can change them on a per-file basis.
1292 ;; 1275 ;;
1293 (byte-compile-verbose byte-compile-verbose) 1276 (byte-compile-verbose byte-compile-verbose)
1294 (byte-optimize byte-optimize) 1277 (byte-optimize byte-optimize)
1295 (byte-compile-emacs18-compatibility 1278 (byte-compile-emacs19-compatibility
1296 byte-compile-emacs18-compatibility) 1279 byte-compile-emacs19-compatibility)
1297 (byte-compile-dynamic byte-compile-dynamic) 1280 (byte-compile-dynamic byte-compile-dynamic)
1298 (byte-compile-dynamic-docstrings 1281 (byte-compile-dynamic-docstrings
1299 byte-compile-dynamic-docstrings) 1282 byte-compile-dynamic-docstrings)
1300 (byte-compile-warnings (if (eq byte-compile-warnings t) 1283 (byte-compile-warnings (if (eq byte-compile-warnings t)
1301 byte-compile-default-warnings 1284 byte-compile-default-warnings
1668 (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) 1651 (let ((dynamic-docstrings byte-compile-dynamic-docstrings))
1669 (set-buffer byte-compile-outbuffer) 1652 (set-buffer byte-compile-outbuffer)
1670 (goto-char 1) 1653 (goto-char 1)
1671 ;; 1654 ;;
1672 ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After that is 1655 ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After that is
1673 ;; the file-format version number (18 or 19) as a byte, followed by some 1656 ;; the file-format version number (19 or 20) as a byte, followed by some
1674 ;; nulls. The primary motivation for doing this is to get some binary 1657 ;; nulls. The primary motivation for doing this is to get some binary
1675 ;; characters up in the first line of the file so that `diff' will simply 1658 ;; characters up in the first line of the file so that `diff' will simply
1676 ;; say "Binary files differ" instead of actually doing a diff of two .elc 1659 ;; say "Binary files differ" instead of actually doing a diff of two .elc
1677 ;; files. An extra benefit is that you can add this to /etc/magic: 1660 ;; files. An extra benefit is that you can add this to /etc/magic:
1678 ;; 1661 ;;
1679 ;; 0 string ;ELC GNU Emacs Lisp compiled file, 1662 ;; 0 string ;ELC GNU Emacs Lisp compiled file,
1680 ;; >4 byte x version %d 1663 ;; >4 byte x version %d
1681 ;; 1664 ;;
1682 (insert 1665 (insert
1683 ";ELC" 1666 ";ELC"
1684 (if (byte-compile-version-cond byte-compile-emacs18-compatibility) 18 19) 1667 (if (byte-compile-version-cond byte-compile-emacs19-compatibility) 19 20)
1685 "\000\000\000\n" 1668 "\000\000\000\n"
1686 ) 1669 )
1687 (insert ";;; compiled by " 1670 (insert ";;; compiled by "
1688 (or (and (boundp 'user-mail-address) user-mail-address) 1671 (or (and (boundp 'user-mail-address) user-mail-address)
1689 (concat (user-login-name) "@" (system-name))) 1672 (concat (user-login-name) "@" (system-name)))
1694 (cond 1677 (cond
1695 ((eq byte-optimize 'source) "source-level optimization only") 1678 ((eq byte-optimize 'source) "source-level optimization only")
1696 ((eq byte-optimize 'byte) "byte-level optimization only") 1679 ((eq byte-optimize 'byte) "byte-level optimization only")
1697 (byte-optimize "optimization is on") 1680 (byte-optimize "optimization is on")
1698 (t "optimization is off")) 1681 (t "optimization is off"))
1699 (if (byte-compile-version-cond byte-compile-emacs18-compatibility) 1682 (if (byte-compile-version-cond byte-compile-emacs19-compatibility)
1700 "; compiled with Emacs 18 compatibility.\n" 1683 "; compiled with Emacs 19 compatibility.\n"
1701 ".\n")) 1684 ".\n"))
1702 (if (not (byte-compile-version-cond byte-compile-emacs18-compatibility)) 1685 (if (not (byte-compile-version-cond byte-compile-emacs19-compatibility))
1703 (insert ";;; this file uses opcodes which do not exist in Emacs 18.\n" 1686 (insert ";;; this file uses opcodes which do not exist in Emacs 19.\n"
1704 ;; Have to check if emacs-version is bound so that this works 1687 ;; Have to check if emacs-version is bound so that this works
1705 ;; in files loaded early in loadup.el. 1688 ;; in files loaded early in loadup.el.
1706 "\n(if (and (boundp 'emacs-version)\n" 1689 "\n(if (and (boundp 'emacs-version)\n"
1707 "\t (or (and (boundp 'epoch::version) epoch::version)\n" 1690 "\t (or (and (boundp 'epoch::version) epoch::version)\n"
1708 (if dynamic-docstrings 1691 "\t (string-lessp emacs-version \"20\")))\n"
1709 "\t (string-lessp emacs-version \"19.14\")))\n" 1692 " (error \"`"
1710 "\t (string-lessp emacs-version \"19\")))\n") 1693 ;; prin1-to-string is used to quote backslashes.
1711 " (error \"`" 1694 (substring (prin1-to-string (file-name-nondirectory filename))
1712 ;; prin1-to-string is used to quote backslashes. 1695 1 -1)
1713 (substring (prin1-to-string (file-name-nondirectory filename)) 1696 "' was compiled for Emacs 20\"))\n\n"))
1714 1 -1) 1697 (insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n"
1715 (if dynamic-docstrings 1698 "\n")
1716 "' was compiled for XEmacs 19.14/Emacs 19.29 or later\"))\n\n" 1699 (if (and (byte-compile-version-cond byte-compile-emacs19-compatibility)
1717 "' was compiled for Emacs 19\"))\n\n")) 1700 dynamic-docstrings)
1718 (insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n" 1701 (insert ";;; this file uses opcodes which do not exist prior to\n"
1719 "\n") 1702 ";;; XEmacs 19.14/GNU Emacs 19.29 or later."
1720 ))) 1703 ;; Have to check if emacs-version is bound so that this works
1721 1704 ;; in files loaded early in loadup.el.
1705 "\n(if (and (boundp 'emacs-version)\n"
1706 "\t (or (and (boundp 'epoch::version) epoch::version)\n"
1707 "\t (and (not (string-match \"XEmacs\" emacs-version))\n"
1708 "\t (string-lessp emacs-version \"19.29\"))n"
1709 "\t (string-lessp emacs-version \"19.14\")))\n"
1710 " (error \"`"
1711 ;; prin1-to-string is used to quote backslashes.
1712 (substring (prin1-to-string (file-name-nondirectory filename))
1713 1 -1)
1714 "' was compiled for XEmacs 19.14/Emacs 19.29 or later\"))\n\n"
1715 )
1716 ))
1717
1718 ;; back in the inbuffer; determine and set the coding system for the .elc
1719 ;; file if under Mule. If there are any extended characters in the
1720 ;; input file, use `escape-quoted' to make sure that both binary and
1721 ;; extended characters are output properly and distinguished properly.
1722 ;; Otherwise, use `no-conversion' for maximum portability with non-Mule
1723 ;; Emacsen.
1724 (if (featurep 'mule)
1725 (if (save-excursion
1726 (set-buffer byte-compile-inbuffer)
1727 (goto-char (point-min))
1728 ;; mrb- There must be a better way than skip-chars-forward
1729 (skip-chars-forward (concat (char-to-string 0) "-"
1730 (char-to-string 255)))
1731 (eq (point) (point-max)))
1732 (setq file-coding-system 'no-conversion)
1733 (insert ";;;###coding system: escape-quoted\n")
1734 (setq file-coding-system 'escape-quoted)
1735 ;; Lazy loading not yet implemented for MULE files
1736 ;; mrb - Fix this someday.
1737 (save-excursion
1738 (set-buffer byte-compile-inbuffer)
1739 (setq byte-compile-dynamic nil
1740 byte-compile-dynamic-docstrings nil))
1741 ;;(external-debugging-output (prin1-to-string (buffer-local-variables))))
1742 ))
1743 )
1722 1744
1723 1745
1724 (defun byte-compile-output-file-form (form) 1746 (defun byte-compile-output-file-form (form)
1725 ;; writes the given form to the output buffer, being careful of docstrings 1747 ;; writes the given form to the output buffer, being careful of docstrings
1726 ;; in defun, defmacro, defvar, defconst and autoload because make-docfile is 1748 ;; in defun, defmacro, defvar, defconst and autoload because make-docfile is
2087 (byte-compile-flush-pending) 2109 (byte-compile-flush-pending)
2088 (if (not (stringp (nth 3 form))) 2110 (if (not (stringp (nth 3 form)))
2089 ;; No doc string. Provide -1 as the "doc string index" 2111 ;; No doc string. Provide -1 as the "doc string index"
2090 ;; so that no element will be treated as a doc string. 2112 ;; so that no element will be treated as a doc string.
2091 (byte-compile-output-docform 2113 (byte-compile-output-docform
2092 (if (byte-compile-version-cond byte-compile-emacs18-compatibility) 2114 "\n(defalias '"
2093 "\n(fset '" "\n(defalias '")
2094 name 2115 name
2095 (cond ((atom code) 2116 (cond ((atom code)
2096 (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]"))) 2117 (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]")))
2097 ((eq (car code) 'quote) 2118 ((eq (car code) 'quote)
2098 (setq code new-one) 2119 (setq code new-one)
2108 1) 2129 1)
2109 nil) 2130 nil)
2110 ;; Output the form by hand, that's much simpler than having 2131 ;; Output the form by hand, that's much simpler than having
2111 ;; b-c-output-file-form analyze the defalias. 2132 ;; b-c-output-file-form analyze the defalias.
2112 (byte-compile-output-docform 2133 (byte-compile-output-docform
2113 (if (byte-compile-version-cond byte-compile-emacs18-compatibility) 2134 "\n(defalias '"
2114 "\n(fset '" "\n(defalias '")
2115 name 2135 name
2116 (cond ((atom code) ; compiled-function-p 2136 (cond ((atom code) ; compiled-function-p
2117 (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))) 2137 (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]")))
2118 ((eq (car code) 'quote) 2138 ((eq (car code) 'quote)
2119 (setq code new-one) 2139 (setq code new-one)
2241 (byte-compile-warn-about-unresolved-functions msg))))) 2261 (byte-compile-warn-about-unresolved-functions msg)))))
2242 2262
2243 ;; Given a function made by byte-compile-lambda, make a form which produces it. 2263 ;; Given a function made by byte-compile-lambda, make a form which produces it.
2244 (defun byte-compile-byte-code-maker (fun) 2264 (defun byte-compile-byte-code-maker (fun)
2245 (cond 2265 (cond
2246 ((byte-compile-version-cond byte-compile-emacs18-compatibility)
2247 ;; Return (quote (lambda ...)).
2248 (list 'quote (byte-compile-byte-code-unmake fun)))
2249 ;; ## atom is faster than compiled-func-p. 2266 ;; ## atom is faster than compiled-func-p.
2250 ((atom fun) ; compiled-function-p 2267 ((atom fun) ; compiled-function-p
2251 ;; generate-emacs19-bytecodes must be on, otherwise byte-compile-lambda
2252 ;; would have produced a lambda.
2253 fun) 2268 fun)
2254 ;; b-c-lambda didn't produce a compiled-function, so it's either a trivial 2269 ;; b-c-lambda didn't produce a compiled-function, so it must be a trivial
2255 ;; function, or this is Emacs 18, or generate-emacs19-bytecodes is off. 2270 ;; function.
2256 ((let (tmp) 2271 ((let (tmp)
2257 (if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun)))) 2272 (if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun))))
2258 (null (cdr (memq tmp fun)))) 2273 (null (cdr (memq tmp fun))))
2259 ;; Generate a make-byte-code call. 2274 ;; Generate a make-byte-code call.
2260 (let* ((interactive (assq 'interactive (cdr (cdr fun))))) 2275 (let* ((interactive (assq 'interactive (cdr (cdr fun)))))
2274 ;; Interactive spec is a list or a variable 2289 ;; Interactive spec is a list or a variable
2275 ;; (if it is correct). 2290 ;; (if it is correct).
2276 (list 'quote (nth 1 interactive)))))))) 2291 (list 'quote (nth 1 interactive))))))))
2277 ;; a non-compiled function (probably trivial) 2292 ;; a non-compiled function (probably trivial)
2278 (list 'quote fun)))))) 2293 (list 'quote fun))))))
2279
2280 ;; Turn a function into an ordinary lambda. Needed for v18 files.
2281 (defun byte-compile-byte-code-unmake (function)
2282 (if (consp function)
2283 function ; It already is a lambda.
2284
2285 (nconc (list 'lambda (compiled-function-arglist function))
2286 (let ((doc (documentation function t)))
2287 (if doc (list doc)))
2288 (if (commandp function)
2289 (list (compiled-function-interactive function)))
2290 (list (list 'byte-code
2291 (compiled-function-instructions function)
2292 (compiled-function-constants function)
2293 (compiled-function-stack-depth function))))))
2294
2295 2294
2296 ;; Byte-compile a lambda-expression and return a valid function. 2295 ;; Byte-compile a lambda-expression and return a valid function.
2297 ;; The value is usually a compiled function but may be the original 2296 ;; The value is usually a compiled function but may be the original
2298 ;; lambda-expression. 2297 ;; lambda-expression.
2299 (defun byte-compile-lambda (fun) 2298 (defun byte-compile-lambda (fun)
2352 (prin1-to-string int)))))) 2351 (prin1-to-string int))))))
2353 (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda))) 2352 (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda)))
2354 (if (memq 'unused-vars byte-compile-warnings) 2353 (if (memq 'unused-vars byte-compile-warnings)
2355 ;; done compiling in this scope, warn now. 2354 ;; done compiling in this scope, warn now.
2356 (byte-compile-warn-about-unused-variables)) 2355 (byte-compile-warn-about-unused-variables))
2357 (if (and (eq 'byte-code (car-safe compiled)) 2356 (if (eq 'byte-code (car-safe compiled))
2358 (not (byte-compile-version-cond
2359 byte-compile-emacs18-compatibility)))
2360 (apply 'make-byte-code 2357 (apply 'make-byte-code
2361 (append (list arglist) 2358 (append (list arglist)
2362 ;; byte-string, constants-vector, stack depth 2359 ;; byte-string, constants-vector, stack depth
2363 (cdr compiled) 2360 (cdr compiled)
2364 ;; optionally, the doc string. 2361 ;; optionally, the doc string.
2494 (setq body (cons (list 'quote tmp) body))) 2491 (setq body (cons (list 'quote tmp) body)))
2495 (setq body (cons tmp body)))) 2492 (setq body (cons tmp body))))
2496 ((and maycall 2493 ((and maycall
2497 ;; Allow a funcall if at most one atom follows it. 2494 ;; Allow a funcall if at most one atom follows it.
2498 (null (nthcdr 3 rest)) 2495 (null (nthcdr 3 rest))
2499 (setq tmp (get (car (car rest)) 'byte-opcode-invert)) 2496 (setq tmp
2497 ;; XEmacs change for rms funs
2498 (or (and
2499 (byte-compile-version-cond
2500 byte-compile-emacs19-compatibility)
2501 (get (car (car rest))
2502 'byte-opcode19-invert))
2503 (get (car (car rest))
2504 'byte-opcode-invert)))
2500 (or (null (cdr rest)) 2505 (or (null (cdr rest))
2501 (and (memq output-type '(file progn t)) 2506 (and (memq output-type '(file progn t))
2502 (cdr (cdr rest)) 2507 (cdr (cdr rest))
2503 (eq (car (nth 1 rest)) 'byte-discard) 2508 (eq (car (nth 1 rest)) 'byte-discard)
2504 (progn (setq rest (cdr rest)) t)))) 2509 (progn (setq rest (cdr rest)) t))))
2553 (handler (get fn 'byte-compile))) 2558 (handler (get fn 'byte-compile)))
2554 (if (memq fn '(t nil)) 2559 (if (memq fn '(t nil))
2555 (byte-compile-warn "%s called as a function" fn)) 2560 (byte-compile-warn "%s called as a function" fn))
2556 (if (and handler 2561 (if (and handler
2557 (or (not (byte-compile-version-cond 2562 (or (not (byte-compile-version-cond
2558 byte-compile-emacs18-compatibility)) 2563 byte-compile-emacs19-compatibility))
2559 (not (get (get fn 'byte-opcode) 'emacs19-opcode)))) 2564 (not (get (get fn 'byte-opcode) 'emacs20-opcode))))
2560 (funcall handler form) 2565 (funcall handler form)
2561 (if (memq 'callargs byte-compile-warnings) 2566 (if (memq 'callargs byte-compile-warnings)
2562 (byte-compile-callargs-warn form)) 2567 (byte-compile-callargs-warn form))
2563 (byte-compile-normal-call form)))) 2568 (byte-compile-normal-call form))))
2564 ((and (or (compiled-function-p (car form)) 2569 ((and (or (compiled-function-p (car form))
2591 (prin1-to-string var)) 2596 (prin1-to-string var))
2592 (if (and (get var 'byte-obsolete-variable) 2597 (if (and (get var 'byte-obsolete-variable)
2593 (memq 'obsolete byte-compile-warnings)) 2598 (memq 'obsolete byte-compile-warnings))
2594 (let ((ob (get var 'byte-obsolete-variable))) 2599 (let ((ob (get var 'byte-obsolete-variable)))
2595 (byte-compile-warn "%s is an obsolete variable; %s" var 2600 (byte-compile-warn "%s is an obsolete variable; %s" var
2596 (if (stringp ob)
2597 ob
2598 (format "use %s instead." ob)))))
2599 (if (and (get var 'byte-compatible-variable)
2600 (memq 'pedantic byte-compile-warnings))
2601 (let ((ob (get var 'byte-compatible-variable)))
2602 (byte-compile-warn "%s is provided for compatibility; %s" var
2603 (if (stringp ob) 2601 (if (stringp ob)
2604 ob 2602 ob
2605 (format "use %s instead." ob))))) 2603 (format "use %s instead." ob)))))
2606 (if (memq 'free-vars byte-compile-warnings) 2604 (if (memq 'free-vars byte-compile-warnings)
2607 (if (eq base-op 'byte-varbind) 2605 (if (eq base-op 'byte-varbind)
2700 ''byte-opcode (list 'quote opcode)) 2698 ''byte-opcode (list 'quote opcode))
2701 (list 'put (list 'quote opcode) 2699 (list 'put (list 'quote opcode)
2702 ''byte-opcode-invert (list 'quote function))) 2700 ''byte-opcode-invert (list 'quote function)))
2703 fnform)))) 2701 fnform))))
2704 2702
2705 (defmacro byte-defop-compiler19 (function &optional compile-handler) 2703 (defmacro byte-defop-compiler20 (function &optional compile-handler)
2706 ;; Just like byte-defop-compiler, but defines an opcode that will only 2704 ;; Just like byte-defop-compiler, but defines an opcode that will only
2707 ;; be used when byte-compile-emacs18-compatibility is false. 2705 ;; be used when byte-compile-emacs19-compatibility is false.
2708 (if (and (byte-compile-single-version) 2706 (if (and (byte-compile-single-version)
2709 byte-compile-emacs18-compatibility) 2707 byte-compile-emacs19-compatibility)
2710 ;; #### instead of doing nothing, this should do some remprops, 2708 ;; #### instead of doing nothing, this should do some remprops,
2711 ;; #### to protect against the case where a single-version compiler 2709 ;; #### to protect against the case where a single-version compiler
2712 ;; #### is loaded into a world that has contained a multi-version one. 2710 ;; #### is loaded into a world that has contained a multi-version one.
2713 nil 2711 nil
2714 (list 'progn 2712 (list 'progn
2715 (list 'put 2713 (list 'put
2716 (list 'quote 2714 (list 'quote
2717 (or (car (cdr-safe function)) 2715 (or (car (cdr-safe function))
2718 (intern (concat "byte-" 2716 (intern (concat "byte-"
2719 (symbol-name (or (car-safe function) function)))))) 2717 (symbol-name (or (car-safe function) function))))))
2720 ''emacs19-opcode t) 2718 ''emacs20-opcode t)
2721 (list 'byte-defop-compiler function compile-handler)))) 2719 (list 'byte-defop-compiler function compile-handler))))
2720
2721 ;; XEmacs addition:
2722 (defmacro byte-defop-compiler-rmsfun (function &optional compile-handler)
2723 ;; for functions like `eq' that compile into different opcodes depending
2724 ;; on the Emacs version: byte-old-eq for v19, byte-eq for v20.
2725 (let ((opcode (intern (concat "byte-" (symbol-name function))))
2726 (opcode19 (intern (concat "byte-old-" (symbol-name function))))
2727 (fnform
2728 (list 'put (list 'quote function) ''byte-compile
2729 (list 'quote
2730 (or (cdr (assq compile-handler
2731 '((2 . byte-compile-two-args-19->20)
2732 )))
2733 compile-handler
2734 (intern (concat "byte-compile-"
2735 (symbol-name function))))))))
2736 (list 'progn fnform
2737 (list 'put (list 'quote function)
2738 ''byte-opcode (list 'quote opcode))
2739 (list 'put (list 'quote function)
2740 ''byte-opcode19 (list 'quote opcode19))
2741 (list 'put (list 'quote opcode)
2742 ''byte-opcode-invert (list 'quote function))
2743 (list 'put (list 'quote opcode19)
2744 ''byte-opcode19-invert (list 'quote function)))))
2722 2745
2723 (defmacro byte-defop-compiler-1 (function &optional compile-handler) 2746 (defmacro byte-defop-compiler-1 (function &optional compile-handler)
2724 (list 'byte-defop-compiler (list function nil) compile-handler)) 2747 (list 'byte-defop-compiler (list function nil) compile-handler))
2725 2748
2726 2749
2738 2761
2739 (byte-defop-compiler (dot byte-point) 0+1) 2762 (byte-defop-compiler (dot byte-point) 0+1)
2740 (byte-defop-compiler (dot-max byte-point-max) 0+1) 2763 (byte-defop-compiler (dot-max byte-point-max) 0+1)
2741 (byte-defop-compiler (dot-min byte-point-min) 0+1) 2764 (byte-defop-compiler (dot-min byte-point-min) 0+1)
2742 (byte-defop-compiler point 0+1) 2765 (byte-defop-compiler point 0+1)
2743 ;;(byte-defop-compiler mark 0) ;; obsolete 2766 (byte-defop-compiler-rmsfun eq 2)
2744 (byte-defop-compiler point-max 0+1) 2767 (byte-defop-compiler point-max 0+1)
2745 (byte-defop-compiler point-min 0+1) 2768 (byte-defop-compiler point-min 0+1)
2746 (byte-defop-compiler following-char 0+1) 2769 (byte-defop-compiler following-char 0+1)
2747 (byte-defop-compiler preceding-char 0+1) 2770 (byte-defop-compiler preceding-char 0+1)
2748 (byte-defop-compiler current-column 0+1) 2771 (byte-defop-compiler current-column 0+1)
2749 ;; FSF has special function here; generalized here by the 1+2 stuff. 2772 ;; FSF has special function here; generalized here by the 1+2 stuff.
2750 (byte-defop-compiler (indent-to-column byte-indent-to) 1+2) 2773 (byte-defop-compiler (indent-to-column byte-indent-to) 1+2)
2751 (byte-defop-compiler indent-to 1+2) 2774 (byte-defop-compiler indent-to 1+2)
2775 (byte-defop-compiler-rmsfun equal 2)
2752 (byte-defop-compiler eolp 0+1) 2776 (byte-defop-compiler eolp 0+1)
2753 (byte-defop-compiler eobp 0+1) 2777 (byte-defop-compiler eobp 0+1)
2754 (byte-defop-compiler bolp 0+1) 2778 (byte-defop-compiler bolp 0+1)
2755 (byte-defop-compiler bobp 0+1) 2779 (byte-defop-compiler bobp 0+1)
2756 (byte-defop-compiler current-buffer 0) 2780 (byte-defop-compiler current-buffer 0)
2757 ;;(byte-defop-compiler read-char 0) ;; obsolete 2781 ;;(byte-defop-compiler read-char 0) ;; obsolete
2782 (byte-defop-compiler-rmsfun memq 2)
2758 (byte-defop-compiler interactive-p 0) 2783 (byte-defop-compiler interactive-p 0)
2759 (byte-defop-compiler19 widen 0+1) 2784 (byte-defop-compiler widen 0+1)
2760 (byte-defop-compiler19 end-of-line 0-1+1) 2785 (byte-defop-compiler end-of-line 0-1+1)
2761 (byte-defop-compiler19 forward-char 0-1+1) 2786 (byte-defop-compiler forward-char 0-1+1)
2762 (byte-defop-compiler19 forward-line 0-1+1) 2787 (byte-defop-compiler forward-line 0-1+1)
2763 (byte-defop-compiler symbolp 1) 2788 (byte-defop-compiler symbolp 1)
2764 (byte-defop-compiler consp 1) 2789 (byte-defop-compiler consp 1)
2765 (byte-defop-compiler stringp 1) 2790 (byte-defop-compiler stringp 1)
2766 (byte-defop-compiler listp 1) 2791 (byte-defop-compiler listp 1)
2767 (byte-defop-compiler not 1) 2792 (byte-defop-compiler not 1)
2775 (byte-defop-compiler (1- byte-sub1) 1) 2800 (byte-defop-compiler (1- byte-sub1) 1)
2776 (byte-defop-compiler goto-char 1+1) 2801 (byte-defop-compiler goto-char 1+1)
2777 (byte-defop-compiler char-after 1+1) 2802 (byte-defop-compiler char-after 1+1)
2778 (byte-defop-compiler set-buffer 1) 2803 (byte-defop-compiler set-buffer 1)
2779 ;;(byte-defop-compiler set-mark 1) ;; obsolete 2804 ;;(byte-defop-compiler set-mark 1) ;; obsolete
2780 (byte-defop-compiler19 forward-word 1+1) 2805 (byte-defop-compiler forward-word 1+1)
2781 (byte-defop-compiler19 char-syntax 1+1) 2806 (byte-defop-compiler char-syntax 1+1)
2782 (byte-defop-compiler19 nreverse 1) 2807 (byte-defop-compiler nreverse 1)
2783 (byte-defop-compiler19 car-safe 1) 2808 (byte-defop-compiler car-safe 1)
2784 (byte-defop-compiler19 cdr-safe 1) 2809 (byte-defop-compiler cdr-safe 1)
2785 (byte-defop-compiler19 numberp 1) 2810 (byte-defop-compiler numberp 1)
2786 (byte-defop-compiler19 integerp 1) 2811 (byte-defop-compiler integerp 1)
2787 (byte-defop-compiler19 skip-chars-forward 1-2+1) 2812 (byte-defop-compiler skip-chars-forward 1-2+1)
2788 (byte-defop-compiler19 skip-chars-backward 1-2+1) 2813 (byte-defop-compiler skip-chars-backward 1-2+1)
2789 ;;(byte-defop-compiler (eql byte-eq) 2) 2814 (byte-defop-compiler (eql byte-eq) 2)
2790 (byte-defop-compiler eq 2) 2815 (byte-defop-compiler20 old-eq 2)
2791 (byte-defop-compiler memq 2) 2816 (byte-defop-compiler20 old-memq 2)
2792 (byte-defop-compiler cons 2) 2817 (byte-defop-compiler cons 2)
2793 (byte-defop-compiler aref 2) 2818 (byte-defop-compiler aref 2)
2794 (byte-defop-compiler (= byte-eqlsign) 2) 2819 (byte-defop-compiler (= byte-eqlsign) 2)
2795 (byte-defop-compiler (< byte-lss) 2) 2820 (byte-defop-compiler (< byte-lss) 2)
2796 (byte-defop-compiler (> byte-gtr) 2) 2821 (byte-defop-compiler (> byte-gtr) 2)
2797 (byte-defop-compiler (<= byte-leq) 2) 2822 (byte-defop-compiler (<= byte-leq) 2)
2798 (byte-defop-compiler (>= byte-geq) 2) 2823 (byte-defop-compiler (>= byte-geq) 2)
2799 (byte-defop-compiler get 2+1) 2824 (byte-defop-compiler get 2+1)
2800 (byte-defop-compiler nth 2) 2825 (byte-defop-compiler nth 2)
2801 (byte-defop-compiler substring 2-3) 2826 (byte-defop-compiler substring 2-3)
2802 (byte-defop-compiler19 (move-marker byte-set-marker) 2-3) 2827 (byte-defop-compiler (move-marker byte-set-marker) 2-3)
2803 (byte-defop-compiler19 set-marker 2-3) 2828 (byte-defop-compiler set-marker 2-3)
2804 (byte-defop-compiler19 match-beginning 1) 2829 (byte-defop-compiler match-beginning 1)
2805 (byte-defop-compiler19 match-end 1) 2830 (byte-defop-compiler match-end 1)
2806 (byte-defop-compiler19 upcase 1+1) 2831 (byte-defop-compiler upcase 1+1)
2807 (byte-defop-compiler19 downcase 1+1) 2832 (byte-defop-compiler downcase 1+1)
2808 (byte-defop-compiler19 string= 2) 2833 (byte-defop-compiler string= 2)
2809 (byte-defop-compiler19 string< 2) 2834 (byte-defop-compiler string< 2)
2810 (byte-defop-compiler19 (string-equal byte-string=) 2) 2835 (byte-defop-compiler (string-equal byte-string=) 2)
2811 (byte-defop-compiler19 (string-lessp byte-string<) 2) 2836 (byte-defop-compiler (string-lessp byte-string<) 2)
2812 (byte-defop-compiler19 equal 2) 2837 (byte-defop-compiler20 old-equal 2)
2813 (byte-defop-compiler19 nthcdr 2) 2838 (byte-defop-compiler nthcdr 2)
2814 (byte-defop-compiler19 elt 2) 2839 (byte-defop-compiler elt 2)
2815 (byte-defop-compiler19 member 2) 2840 (byte-defop-compiler20 old-member 2)
2816 (byte-defop-compiler19 assq 2) 2841 (byte-defop-compiler20 old-assq 2)
2817 (byte-defop-compiler19 (rplaca byte-setcar) 2) 2842 (byte-defop-compiler (rplaca byte-setcar) 2)
2818 (byte-defop-compiler19 (rplacd byte-setcdr) 2) 2843 (byte-defop-compiler (rplacd byte-setcdr) 2)
2819 (byte-defop-compiler19 setcar 2) 2844 (byte-defop-compiler setcar 2)
2820 (byte-defop-compiler19 setcdr 2) 2845 (byte-defop-compiler setcdr 2)
2821 ;; buffer-substring now has its own function. This used to be 2846 ;; buffer-substring now has its own function. This used to be
2822 ;; 2+1, but now all args are optional. 2847 ;; 2+1, but now all args are optional.
2823 (byte-defop-compiler19 buffer-substring) 2848 (byte-defop-compiler buffer-substring)
2824 (byte-defop-compiler19 delete-region 2+1) 2849 (byte-defop-compiler delete-region 2+1)
2825 (byte-defop-compiler19 narrow-to-region 2+1) 2850 (byte-defop-compiler narrow-to-region 2+1)
2826 (byte-defop-compiler19 (% byte-rem) 2) 2851 (byte-defop-compiler (% byte-rem) 2)
2827 (byte-defop-compiler aset 3) 2852 (byte-defop-compiler aset 3)
2853
2854 (byte-defop-compiler-rmsfun member 2)
2855 (byte-defop-compiler-rmsfun assq 2)
2828 2856
2829 (byte-defop-compiler max byte-compile-associative) 2857 (byte-defop-compiler max byte-compile-associative)
2830 (byte-defop-compiler min byte-compile-associative) 2858 (byte-defop-compiler min byte-compile-associative)
2831 (byte-defop-compiler (+ byte-plus) byte-compile-associative) 2859 (byte-defop-compiler (+ byte-plus) byte-compile-associative)
2832 (byte-defop-compiler19 (* byte-mult) byte-compile-associative) 2860 (byte-defop-compiler (* byte-mult) byte-compile-associative)
2833 2861
2834 ;;####(byte-defop-compiler19 move-to-column 1) 2862 ;;####(byte-defop-compiler move-to-column 1)
2835 (byte-defop-compiler-1 interactive byte-compile-noop) 2863 (byte-defop-compiler-1 interactive byte-compile-noop)
2836 (byte-defop-compiler-1 domain byte-compile-domain) 2864 (byte-defop-compiler-1 domain byte-compile-domain)
2837 2865
2838 ;; As of GNU Emacs 19.18 and Lucid Emacs 19.8, mod and % are different: `%' 2866 ;; As of GNU Emacs 19.18 and Lucid Emacs 19.8, mod and % are different: `%'
2839 ;; means integral remainder and may have a negative result; `mod' is always 2867 ;; means integral remainder and may have a negative result; `mod' is always
2841 ;; requires the new interpretation must be compiled with bytecomp version 2.18 2869 ;; requires the new interpretation must be compiled with bytecomp version 2.18
2842 ;; or newer, or the emitted code will run the byte-code for `%' instead of an 2870 ;; or newer, or the emitted code will run the byte-code for `%' instead of an
2843 ;; actual call to `mod'. So be careful of compiling new code with an old 2871 ;; actual call to `mod'. So be careful of compiling new code with an old
2844 ;; compiler. Note also that `%' is more efficient than `mod' because the 2872 ;; compiler. Note also that `%' is more efficient than `mod' because the
2845 ;; former is byte-coded and the latter is not. 2873 ;; former is byte-coded and the latter is not.
2846 ;;(byte-defop-compiler19 (mod byte-rem) 2) 2874 ;;(byte-defop-compiler (mod byte-rem) 2)
2847 2875
2848 2876
2849 (defun byte-compile-subr-wrong-args (form n) 2877 (defun byte-compile-subr-wrong-args (form n)
2850 (byte-compile-warn "%s called with %d arg%s, but requires %s" 2878 (byte-compile-warn "%s called with %d arg%s, but requires %s"
2851 (car form) (length (cdr form)) 2879 (car form) (length (cdr form))
2954 (let ((len (length form))) 2982 (let ((len (length form)))
2955 (cond ((= len 2) (byte-compile-one-arg form)) 2983 (cond ((= len 2) (byte-compile-one-arg form))
2956 ((or (= len 3) (= len 4)) (byte-compile-normal-call form)) 2984 ((or (= len 3) (= len 4)) (byte-compile-normal-call form))
2957 (t (byte-compile-subr-wrong-args form "1-3"))))) 2985 (t (byte-compile-subr-wrong-args form "1-3")))))
2958 2986
2987 ;; XEmacs: used for functions that have a different opcode in v19 than v20.
2988 ;; this includes `eq', `equal', and other old-ified functions.
2989 (defun byte-compile-two-args-19->20 (form)
2990 (if (not (= (length form) 3))
2991 (byte-compile-subr-wrong-args form 2)
2992 (byte-compile-form (car (cdr form))) ;; Push the arguments
2993 (byte-compile-form (nth 2 form))
2994 (if t ;(byte-compile-version-cond byte-compile-emacs19-compatibility)
2995 (byte-compile-out (get (car form) 'byte-opcode19) 0)
2996 (byte-compile-out (get (car form) 'byte-opcode) 0))))
2959 2997
2960 (defun byte-compile-noop (form) 2998 (defun byte-compile-noop (form)
2961 (byte-compile-constant nil)) 2999 (byte-compile-constant nil))
2962 3000
2963 (defun byte-compile-discard () 3001 (defun byte-compile-discard ()
2986 (byte-defop-compiler concat) 3024 (byte-defop-compiler concat)
2987 (byte-defop-compiler fset) 3025 (byte-defop-compiler fset)
2988 (byte-defop-compiler insert) 3026 (byte-defop-compiler insert)
2989 (byte-defop-compiler-1 function byte-compile-function-form) 3027 (byte-defop-compiler-1 function byte-compile-function-form)
2990 (byte-defop-compiler-1 - byte-compile-minus) 3028 (byte-defop-compiler-1 - byte-compile-minus)
2991 (byte-defop-compiler19 (/ byte-quo) byte-compile-quo) 3029 (byte-defop-compiler (/ byte-quo) byte-compile-quo)
2992 (byte-defop-compiler19 nconc) 3030 (byte-defop-compiler nconc)
2993 (byte-defop-compiler-1 beginning-of-line) 3031 (byte-defop-compiler-1 beginning-of-line)
2994 3032
2995 (defun byte-compile-buffer-substring (form) 3033 (defun byte-compile-buffer-substring (form)
2996 (let ((len (length form))) 3034 (let ((len (length form)))
2997 ;; buffer-substring used to take exactly two args, but now takes 0-3. 3035 ;; buffer-substring used to take exactly two args, but now takes 0-3.
3009 (byte-compile-constant nil)) 3047 (byte-compile-constant nil))
3010 ((< count 5) 3048 ((< count 5)
3011 (mapcar 'byte-compile-form (cdr form)) 3049 (mapcar 'byte-compile-form (cdr form))
3012 (byte-compile-out 3050 (byte-compile-out
3013 (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0)) 3051 (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0))
3014 ((and (< count 256) (not (byte-compile-version-cond 3052 ((< count 256)
3015 byte-compile-emacs18-compatibility)))
3016 (mapcar 'byte-compile-form (cdr form)) 3053 (mapcar 'byte-compile-form (cdr form))
3017 (byte-compile-out 'byte-listN count)) 3054 (byte-compile-out 'byte-listN count))
3018 (t (byte-compile-normal-call form))))) 3055 (t (byte-compile-normal-call form)))))
3019 3056
3020 (defun byte-compile-concat (form) 3057 (defun byte-compile-concat (form)
3025 (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2)) 3062 (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2))
3026 0)) 3063 0))
3027 ;; Concat of one arg is not a no-op if arg is not a string. 3064 ;; Concat of one arg is not a no-op if arg is not a string.
3028 ((= count 0) 3065 ((= count 0)
3029 (byte-compile-form "")) 3066 (byte-compile-form ""))
3030 ((and (< count 256) (not (byte-compile-version-cond 3067 ((< count 256)
3031 byte-compile-emacs18-compatibility)))
3032 (mapcar 'byte-compile-form (cdr form)) 3068 (mapcar 'byte-compile-form (cdr form))
3033 (byte-compile-out 'byte-concatN count)) 3069 (byte-compile-out 'byte-concatN count))
3034 ((byte-compile-normal-call form))))) 3070 ((byte-compile-normal-call form)))))
3035 3071
3036 (defun byte-compile-minus (form) 3072 (defun byte-compile-minus (form)
3106 3142
3107 (defun byte-compile-function-form (form) 3143 (defun byte-compile-function-form (form)
3108 (byte-compile-constant 3144 (byte-compile-constant
3109 (cond ((symbolp (nth 1 form)) 3145 (cond ((symbolp (nth 1 form))
3110 (nth 1 form)) 3146 (nth 1 form))
3111 ;; If we're not allowed to use #[] syntax, then output a form like
3112 ;; '(lambda (..) (byte-code ..)) instead of a call to make-byte-code.
3113 ;; In this situation, calling make-byte-code at run-time will usually
3114 ;; be less efficient than processing a call to byte-code.
3115 ((byte-compile-version-cond byte-compile-emacs18-compatibility)
3116 (byte-compile-byte-code-unmake (byte-compile-lambda (nth 1 form))))
3117 ((byte-compile-lambda (nth 1 form)))))) 3147 ((byte-compile-lambda (nth 1 form))))))
3118 3148
3119 (defun byte-compile-insert (form) 3149 (defun byte-compile-insert (form)
3120 (cond ((null (cdr form)) 3150 (cond ((null (cdr form))
3121 (byte-compile-constant nil)) 3151 (byte-compile-constant nil))
3122 ((and (not (byte-compile-version-cond 3152 ((<= (length form) 256)
3123 byte-compile-emacs18-compatibility))
3124 (<= (length form) 256))
3125 (mapcar 'byte-compile-form (cdr form)) 3153 (mapcar 'byte-compile-form (cdr form))
3126 (if (cdr (cdr form)) 3154 (if (cdr (cdr form))
3127 (byte-compile-out 'byte-insertN (length (cdr form))) 3155 (byte-compile-out 'byte-insertN (length (cdr form)))
3128 (byte-compile-out 'byte-insert 0))) 3156 (byte-compile-out 'byte-insert 0)))
3129 ((memq t (mapcar 'consp (cdr (cdr form)))) 3157 ((memq t (mapcar 'consp (cdr (cdr form))))