![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to bytecomp.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp|
Return to bytecomp.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp |
1.1 ! root 1: ;; Compilation of Lisp code into byte code. ! 2: ;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. ! 3: ! 4: ;; This file is part of GNU Emacs. ! 5: ! 6: ;; GNU Emacs is distributed in the hope that it will be useful, ! 7: ;; but WITHOUT ANY WARRANTY. No author or distributor ! 8: ;; accepts responsibility to anyone for the consequences of using it ! 9: ;; or for whether it serves any particular purpose or works at all, ! 10: ;; unless he says so in writing. Refer to the GNU Emacs General Public ! 11: ;; License for full details. ! 12: ! 13: ;; Everyone is granted permission to copy, modify and redistribute ! 14: ;; GNU Emacs, but only under the conditions described in the ! 15: ;; GNU Emacs General Public License. A copy of this license is ! 16: ;; supposed to have been given to you along with GNU Emacs so you ! 17: ;; can know your rights and responsibilities. It should be in a ! 18: ;; file named COPYING. Among other things, the copyright notice ! 19: ;; and this notice must be preserved on all copies. ! 20: ! 21: (provide 'byte-compile) ! 22: ! 23: (defvar byte-compile-constnum -1 ! 24: "Transfer vector index of last constant allocated.") ! 25: (defvar byte-compile-constants nil ! 26: "Alist describing contents to put in transfer vector. ! 27: Each element is (CONTENTS . INDEX)") ! 28: (defvar byte-compile-macro-environment nil ! 29: "Alist of (MACRONAME . DEFINITION) macros defined in the file ! 30: which is being compiled.") ! 31: (defvar byte-compile-pc 0 ! 32: "Index in byte string to store next opcode at.") ! 33: (defvar byte-compile-output nil ! 34: "Alist describing contents to put in byte code string. ! 35: Each element is (INDEX . VALUE)") ! 36: (defvar byte-compile-depth 0 ! 37: "Current depth of execution stack.") ! 38: (defvar byte-compile-maxdepth 0 ! 39: "Maximum depth of execution stack.") ! 40: ! 41: (defconst byte-varref 8 ! 42: "Byte code opcode for variable reference.") ! 43: (defconst byte-varset 16 ! 44: "Byte code opcode for setting a variable.") ! 45: (defconst byte-varbind 24 ! 46: "Byte code opcode for binding a variable.") ! 47: (defconst byte-call 32 ! 48: "Byte code opcode for calling a function.") ! 49: (defconst byte-unbind 40 ! 50: "Byte code opcode for unbinding special bindings.") ! 51: ! 52: (defconst byte-constant 192 ! 53: "Byte code opcode for reference to a constant.") ! 54: (defconst byte-constant-limit 64 ! 55: "Maximum index usable in byte-constant opcode.") ! 56: ! 57: (defconst byte-constant2 129 ! 58: "Byte code opcode for reference to a constant with vector index >= 0100.") ! 59: ! 60: (defconst byte-goto 130 ! 61: "Byte code opcode for unconditional jump") ! 62: ! 63: (defconst byte-goto-if-nil 131 ! 64: "Byte code opcode for pop value and jump if it's nil.") ! 65: ! 66: (defconst byte-goto-if-not-nil 132 ! 67: "Byte code opcode for pop value and jump if it's not nil.") ! 68: ! 69: (defconst byte-goto-if-nil-else-pop 133 ! 70: "Byte code opcode for examine top-of-stack, jump and don't pop it if it's nil, ! 71: otherwise pop it.") ! 72: ! 73: (defconst byte-goto-if-not-nil-else-pop 134 ! 74: "Byte code opcode for examine top-of-stack, jump and don't pop it if it's not nil, ! 75: otherwise pop it.") ! 76: ! 77: (defconst byte-return 135 ! 78: "Byte code opcode for pop value and return it from byte code interpreter.") ! 79: ! 80: (defconst byte-discard 136 ! 81: "Byte code opcode to discard one value from stack.") ! 82: ! 83: (defconst byte-dup 137 ! 84: "Byte code opcode to duplicate the top of the stack.") ! 85: ! 86: (defconst byte-save-excursion 138 ! 87: "Byte code opcode to make a binding to record the buffer, point and mark.") ! 88: ! 89: (defconst byte-save-window-excursion 139 ! 90: "Byte code opcode to make a binding to record entire window configuration.") ! 91: ! 92: (defconst byte-save-restriction 140 ! 93: "Byte code opcode to make a binding to record the current buffer clipping restrictions.") ! 94: ! 95: (defconst byte-catch 141 ! 96: "Byte code opcode for catch. Takes, on stack, the tag and an expression for the body.") ! 97: ! 98: (defconst byte-unwind-protect 142 ! 99: "Byte code opcode for unwind-protect. Takes, on stack, an expression for the body ! 100: and an expression for the unwind-action.") ! 101: ! 102: (defconst byte-condition-case 143 ! 103: "Byte code opcode for condition-case. Takes, on stack, the variable to bind, ! 104: an expression for the body, and a list of clauses.") ! 105: ! 106: (defconst byte-temp-output-buffer-setup 144 ! 107: "Byte code opcode for entry to with-output-to-temp-buffer. ! 108: Takes, on stack, the buffer name. ! 109: Binds standard-output and does some other things. ! 110: Returns with temp buffer on the stack in place of buffer name.") ! 111: ! 112: (defconst byte-temp-output-buffer-show 145 ! 113: "Byte code opcode for exit from with-output-to-temp-buffer. ! 114: Expects the temp buffer on the stack underneath value to return. ! 115: Pops them both, then pushes the value back on. ! 116: Unbinds standard-output and makes the temp buffer visible.") ! 117: ! 118: (defconst byte-nth 56) ! 119: (defconst byte-symbolp 57) ! 120: (defconst byte-consp 58) ! 121: (defconst byte-stringp 59) ! 122: (defconst byte-listp 60) ! 123: (defconst byte-eq 61) ! 124: (defconst byte-memq 62) ! 125: (defconst byte-not 63) ! 126: (defconst byte-car 64) ! 127: (defconst byte-cdr 65) ! 128: (defconst byte-cons 66) ! 129: (defconst byte-list1 67) ! 130: (defconst byte-list2 68) ! 131: (defconst byte-list3 69) ! 132: (defconst byte-list4 70) ! 133: (defconst byte-length 71) ! 134: (defconst byte-aref 72) ! 135: (defconst byte-aset 73) ! 136: (defconst byte-symbol-value 74) ! 137: (defconst byte-symbol-function 75) ! 138: (defconst byte-set 76) ! 139: (defconst byte-fset 77) ! 140: (defconst byte-get 78) ! 141: (defconst byte-substring 79) ! 142: (defconst byte-concat2 80) ! 143: (defconst byte-concat3 81) ! 144: (defconst byte-concat4 82) ! 145: (defconst byte-sub1 83) ! 146: (defconst byte-add1 84) ! 147: (defconst byte-eqlsign 85) ! 148: (defconst byte-gtr 86) ! 149: (defconst byte-lss 87) ! 150: (defconst byte-leq 88) ! 151: (defconst byte-geq 89) ! 152: (defconst byte-diff 90) ! 153: (defconst byte-negate 91) ! 154: (defconst byte-plus 92) ! 155: (defconst byte-max 93) ! 156: (defconst byte-min 94) ! 157: ! 158: (defconst byte-point 96) ! 159: ;(defconst byte-mark 97) no longer generated -- lisp code shouldn't call this very frequently ! 160: (defconst byte-goto-char 98) ! 161: (defconst byte-insert 99) ! 162: (defconst byte-point-max 100) ! 163: (defconst byte-point-min 101) ! 164: (defconst byte-char-after 102) ! 165: (defconst byte-following-char 103) ! 166: (defconst byte-preceding-char 104) ! 167: (defconst byte-current-column 105) ! 168: (defconst byte-indent-to 106) ! 169: ;(defconst byte-scan-buffer 107) no longer generated ! 170: (defconst byte-eolp 108) ! 171: (defconst byte-eobp 109) ! 172: (defconst byte-bolp 110) ! 173: (defconst byte-bobp 111) ! 174: (defconst byte-current-buffer 112) ! 175: (defconst byte-set-buffer 113) ! 176: (defconst byte-read-char 114) ! 177: ;(defconst byte-set-mark 115) ;obsolete ! 178: (defconst byte-interactive-p 116) ! 179: ! 180: (defun byte-recompile-directory (directory &optional arg) ! 181: "Recompile every .el file in DIRECTORY that needs recompilation. ! 182: This is if a .elc file exists but is older than the .el file. ! 183: If the .elc file does not exist, offer to compile the .el file ! 184: only if a prefix argument has been specified." ! 185: (interactive "DByte recompile directory: \nP") ! 186: (save-some-buffers) ! 187: (setq directory (expand-file-name directory)) ! 188: (let ((files (directory-files directory nil "\\.el\\'")) ! 189: (count 0) ! 190: source dest) ! 191: (while files ! 192: (if (and (not (auto-save-file-name-p (car files))) ! 193: (setq source (expand-file-name (car files) directory)) ! 194: (setq dest (concat (file-name-sans-versions source) "c")) ! 195: (if (file-exists-p dest) ! 196: (file-newer-than-file-p source dest) ! 197: (and arg (y-or-n-p (concat "Compile " source "? "))))) ! 198: (progn (byte-compile-file source) ! 199: (setq count (1+ count)))) ! 200: (setq files (cdr files))) ! 201: (message "Done (Total of %d file%s compiled)" ! 202: count (if (= count 1) "" "s")))) ! 203: ! 204: (defun byte-compile-file (filename) ! 205: "Compile a file of Lisp code named FILENAME into a file of byte code. ! 206: The output file's name is made by appending \"c\" to the end of FILENAME." ! 207: (interactive "fByte compile file: ") ! 208: ;; Expand now so we get the current buffer's defaults ! 209: (setq filename (expand-file-name filename)) ! 210: (message "Compiling %s..." filename) ! 211: (let ((inbuffer (get-buffer-create " *Compiler Input*")) ! 212: (outbuffer (get-buffer-create " *Compiler Output*")) ! 213: (byte-compile-macro-environment nil) ! 214: (case-fold-search nil) ! 215: sexp) ! 216: (save-excursion ! 217: (set-buffer inbuffer) ! 218: (erase-buffer) ! 219: (insert-file-contents filename) ! 220: (goto-char 1) ! 221: (set-buffer outbuffer) ! 222: (emacs-lisp-mode) ! 223: (erase-buffer) ! 224: (while (save-excursion ! 225: (set-buffer inbuffer) ! 226: (while (progn (skip-chars-forward " \t\n\^l") ! 227: (looking-at ";")) ! 228: (forward-line 1)) ! 229: (not (eobp))) ! 230: (setq sexp (read inbuffer)) ! 231: (print (byte-compile-file-form sexp) outbuffer)) ! 232: (set-buffer outbuffer) ! 233: (goto-char 1) ! 234: ;; In each defun or autoload, if there is a doc string, ! 235: ;; put a backslash-newline at the front of it. ! 236: (while (search-forward "\n(" nil t) ! 237: (cond ((looking-at "defun \\|autoload ") ! 238: (forward-sexp 3) ! 239: (skip-chars-forward " ") ! 240: (if (looking-at "\"") ! 241: (progn (forward-char 1) ! 242: (insert "\\\n")))))) ! 243: (goto-char 1) ! 244: ;; In each defconst or defvar, if there is a doc string ! 245: ;; and it starts on the same line as the form begins ! 246: ;; (i.e. if there is no newline in a string in the initial value) ! 247: ;; then put in backslash-newline at the start of the doc string. ! 248: (while (search-forward "\n(" nil t) ! 249: (if (looking-at "defvar \\|defconst ") ! 250: (let ((this-line (1- (point)))) ! 251: ;;Go to end of initial value expression ! 252: (if (condition-case () ! 253: (progn (forward-sexp 3) t) ! 254: (error nil)) ! 255: (progn ! 256: (skip-chars-forward " ") ! 257: (and (eq this-line ! 258: (save-excursion (beginning-of-line) (point))) ! 259: (looking-at "\"") ! 260: (progn (forward-char 1) ! 261: (insert "\\\n")))))))) ! 262: (let ((vms-stmlf-recfm t)) ! 263: (write-region 1 (point-max) ! 264: (concat (file-name-sans-versions filename) "c"))) ! 265: (kill-buffer (current-buffer)) ! 266: (kill-buffer inbuffer))) ! 267: t) ! 268: ! 269: ! 270: (defun byte-compile-file-form (form) ! 271: (cond ((not (listp form)) ! 272: form) ! 273: ((memq (car form) '(defun defmacro)) ! 274: (let* ((name (car (cdr form))) ! 275: (tem (assq name byte-compile-macro-environment))) ! 276: (if (eq (car form) 'defun) ! 277: (progn ! 278: (message "Compiling %s (%s)..." filename (nth 1 form)) ! 279: (cond (tem (setcdr tem nil)) ! 280: ((and (fboundp name) ! 281: (eq (car-safe (symbol-function name)) 'macro)) ! 282: ;; shadow existing macro definition ! 283: (setq byte-compile-macro-environment ! 284: (cons (cons name nil) ! 285: byte-compile-macro-environment)))) ! 286: (prog1 (cons 'defun (byte-compile-lambda (cdr form))) ! 287: (if (not noninteractive) ! 288: (message "Compiling %s..." filename)))) ! 289: ;; defmacro ! 290: (if tem ! 291: (setcdr tem (cons 'lambda (cdr (cdr form)))) ! 292: (setq byte-compile-macro-environment ! 293: (cons (cons name (cons 'lambda (cdr (cdr form)))) ! 294: byte-compile-macro-environment))) ! 295: (cons 'defmacro (byte-compile-lambda (cdr form)))))) ! 296: ((eq (car form) 'require) ! 297: (eval form) ! 298: form) ! 299: (t form))) ! 300: ! 301: (defun byte-compile (funname) ! 302: "Byte-compile the definition of function FUNNAME (a symbol)." ! 303: (if (and (fboundp funname) ! 304: (eq (car-safe (symbol-function funname)) 'lambda)) ! 305: (fset funname (byte-compile-lambda (symbol-function funname))))) ! 306: ! 307: (defun byte-compile-lambda (fun) ! 308: (let* ((bodyptr (cdr fun)) ! 309: (int (assq 'interactive (cdr bodyptr))) ! 310: newbody) ! 311: ;; Skip doc string. ! 312: (if (stringp (car (cdr bodyptr))) ! 313: (setq bodyptr (cdr bodyptr))) ! 314: (setq newbody (list (byte-compile-top-level ! 315: (cons 'progn (cdr bodyptr))))) ! 316: (if int ! 317: (setq newbody (cons (if (or (stringp (car (cdr int))) ! 318: (null (car (cdr int)))) ! 319: int ! 320: (list 'interactive ! 321: (byte-compile-top-level (car (cdr int))))) ! 322: newbody))) ! 323: (if (not (eq bodyptr (cdr fun))) ! 324: (setq newbody (cons (nth 2 fun) newbody))) ! 325: (cons (car fun) (cons (car (cdr fun)) newbody)))) ! 326: ! 327: (defun byte-compile-top-level (form) ! 328: (let ((byte-compile-constants nil) ! 329: (byte-compile-constnum nil) ! 330: (byte-compile-pc 0) ! 331: (byte-compile-depth 0) ! 332: (byte-compile-maxdepth 0) ! 333: (byte-compile-output nil) ! 334: (byte-compile-string nil) ! 335: (byte-compile-vector nil)) ! 336: (let (vars temp (i -1)) ! 337: (setq temp (byte-compile-find-vars form)) ! 338: (setq form (car temp)) ! 339: (setq vars (nreverse (cdr temp))) ! 340: (while vars ! 341: (setq i (1+ i)) ! 342: (setq byte-compile-constants (cons (cons (car vars) i) ! 343: byte-compile-constants)) ! 344: (setq vars (cdr vars))) ! 345: (setq byte-compile-constnum i)) ! 346: (byte-compile-form form) ! 347: (byte-compile-out 'byte-return 0) ! 348: (setq byte-compile-vector (make-vector (1+ byte-compile-constnum) ! 349: nil)) ! 350: (while byte-compile-constants ! 351: (aset byte-compile-vector (cdr (car byte-compile-constants)) ! 352: (car (car byte-compile-constants))) ! 353: (setq byte-compile-constants (cdr byte-compile-constants))) ! 354: (setq byte-compile-string (make-string byte-compile-pc 0)) ! 355: (while byte-compile-output ! 356: (aset byte-compile-string (car (car byte-compile-output)) ! 357: (cdr (car byte-compile-output))) ! 358: (setq byte-compile-output (cdr byte-compile-output))) ! 359: (list 'byte-code byte-compile-string ! 360: byte-compile-vector byte-compile-maxdepth))) ! 361: ! 362: ;; Expand all macros in FORM and find all variables it uses. ! 363: ;; Return a pair (EXPANDEDFORM . VARS) ! 364: ;; VARS is ordered with the variables encountered earliest ! 365: ;; at the end. ! 366: ;; The body and cases of a condition-case, and the body of a catch, ! 367: ;; are not scanned; variables used in them are not reported, ! 368: ;; and they are not macroexpanded. This is because they will ! 369: ;; be compiled separately when encountered during the main ! 370: ;; compilation pass. ! 371: (defun byte-compile-find-vars (form) ! 372: (let ((all-vars nil)) ! 373: (cons (byte-compile-find-vars-1 form) ! 374: all-vars))) ! 375: ! 376: ;; Walk FORM, making sure all variables it uses are in ALL-VARS, ! 377: ;; and also expanding macros. ! 378: ;; Return the result of expanding all macros in FORM. ! 379: ;; This is a copy; FORM itself is not altered. ! 380: (defun byte-compile-find-vars-1 (form) ! 381: (cond ((symbolp form) ! 382: (if (not (memq form all-vars)) ! 383: (setq all-vars (cons form all-vars))) ! 384: form) ! 385: ((or (not (consp form)) (eq (car form) 'quote)) ! 386: form) ! 387: ((memq (car form) '(let let*)) ! 388: (let* ((binds (copy-sequence (car (cdr form)))) ! 389: (body (cdr (cdr form))) ! 390: (tail binds)) ! 391: (while tail ! 392: (if (symbolp (car tail)) ! 393: (if (not (memq (car tail) all-vars)) ! 394: (setq all-vars (cons (car tail) all-vars))) ! 395: (if (consp (car tail)) ! 396: (progn ! 397: (if (not (memq (car (car tail)) all-vars)) ! 398: (setq all-vars (cons (car (car tail)) all-vars))) ! 399: (setcar tail ! 400: (list (car (car tail)) ! 401: (byte-compile-find-vars-1 (car (cdr (car tail))))))))) ! 402: (setq tail (cdr tail))) ! 403: (cons (car form) ! 404: (cons binds ! 405: (mapcar 'byte-compile-find-vars-1 body))))) ! 406: ((or (eq (car form) 'function) ! 407: ;; Because condition-case is compiled by breaking out ! 408: ;; all its subexpressions and compiling them separately, ! 409: ;; we regard it here as containing nothing but constants. ! 410: (eq (car form) 'condition-case)) ! 411: form) ! 412: ((eq (car form) 'catch) ! 413: ;; catch is almost like condition case, but we ! 414: ;; treat its first argument normally. ! 415: (cons 'catch ! 416: (cons (byte-compile-find-vars-1 (nth 1 form)) ! 417: (nthcdr 2 form)))) ! 418: ((eq (car form) 'cond) ! 419: (let* ((clauses (copy-sequence (cdr form))) ! 420: (tail clauses)) ! 421: (while tail ! 422: (setcar tail (mapcar 'byte-compile-find-vars-1 (car tail))) ! 423: (setq tail (cdr tail))) ! 424: (cons 'cond clauses))) ! 425: ((not (eq form (setq form (macroexpand form byte-compile-macro-environment)))) ! 426: (byte-compile-find-vars-1 form)) ! 427: ((symbolp (car form)) ! 428: (cons (car form) (mapcar 'byte-compile-find-vars-1 (cdr form)))) ! 429: (t (mapcar 'byte-compile-find-vars-1 form)))) ! 430: ! 431: ;; This is the recursive entry point for compiling each subform of an expression. ! 432: ! 433: ;; Note that handler functions SHOULD NOT increment byte-compile-depth ! 434: ;; for the values they are returning! That is done on return here. ! 435: ;; Handlers should make sure that the depth on exit is the same as ! 436: ;; it was when the handler was called. ! 437: ! 438: (defun byte-compile-form (form) ! 439: (setq form (macroexpand form byte-compile-macro-environment)) ! 440: (cond ((eq form 'nil) ! 441: (byte-compile-constant form)) ! 442: ((eq form 't) ! 443: (byte-compile-constant form)) ! 444: ((symbolp form) ! 445: (byte-compile-variable-ref 'byte-varref form)) ! 446: ((not (consp form)) ! 447: (byte-compile-constant form)) ! 448: (t ! 449: (let ((handler (get (car form) 'byte-compile))) ! 450: (if handler ! 451: (funcall handler form) ! 452: (byte-compile-normal-call form))))) ! 453: (setq byte-compile-maxdepth ! 454: (max byte-compile-maxdepth ! 455: (setq byte-compile-depth (1+ byte-compile-depth))))) ! 456: ! 457: (defun byte-compile-normal-call (form) ! 458: (byte-compile-push-constant (car form)) ! 459: (let ((copy (cdr form))) ! 460: (while copy (byte-compile-form (car copy)) (setq copy (cdr copy)))) ! 461: (byte-compile-out 'byte-call (length (cdr form))) ! 462: (setq byte-compile-depth (- byte-compile-depth (length (cdr form))))) ! 463: ! 464: (defun byte-compile-variable-ref (base-op var) ! 465: (let ((data (assq var byte-compile-constants))) ! 466: (if data ! 467: (byte-compile-out base-op (cdr data)) ! 468: (error (format "Variable %s seen on pass 2 of byte compiler but not pass 1" ! 469: (prin1-to-string var)))))) ! 470: ! 471: ;; Use this when the value of a form is a constant, ! 472: ;; because byte-compile-depth will be incremented accordingly ! 473: ;; on return to byte-compile-form, so it should not be done by the handler. ! 474: (defun byte-compile-constant (const) ! 475: (let ((data (if (stringp const) ! 476: (assoc const byte-compile-constants) ! 477: (assq const byte-compile-constants)))) ! 478: (if data ! 479: (byte-compile-out-const (cdr data)) ! 480: (setq byte-compile-constants ! 481: (cons (cons const (setq byte-compile-constnum (1+ byte-compile-constnum))) ! 482: byte-compile-constants)) ! 483: (byte-compile-out-const byte-compile-constnum)))) ! 484: ! 485: ;; Use this for a constant that is not the value of its containing form. ! 486: ;; Note that the calling function must explicitly decrement byte-compile-depth ! 487: ;; (or perhaps call byte-compile-discard to do so) ! 488: ;; for the word pushed by this function. ! 489: (defun byte-compile-push-constant (const) ! 490: (byte-compile-constant const) ! 491: (setq byte-compile-maxdepth ! 492: (max byte-compile-maxdepth ! 493: (setq byte-compile-depth (1+ byte-compile-depth))))) ! 494: ! 495: ;; Compile those primitive ordinary functions ! 496: ;; which have special byte codes just for speed. ! 497: ! 498: (put 'point 'byte-compile 'byte-compile-no-args) ! 499: (put 'point 'byte-opcode 'byte-point) ! 500: ! 501: (put 'dot 'byte-compile 'byte-compile-no-args) ! 502: (put 'dot 'byte-opcode 'byte-point) ! 503: ! 504: ;(put 'mark 'byte-compile 'byte-compile-no-args) ! 505: ;(put 'mark 'byte-opcode 'byte-mark) ! 506: ! 507: (put 'point-max 'byte-compile 'byte-compile-no-args) ! 508: (put 'point-max 'byte-opcode 'byte-point-max) ! 509: ! 510: (put 'point-min 'byte-compile 'byte-compile-no-args) ! 511: (put 'point-min 'byte-opcode 'byte-point-min) ! 512: ! 513: (put 'dot-max 'byte-compile 'byte-compile-no-args) ! 514: (put 'dot-max 'byte-opcode 'byte-point-max) ! 515: ! 516: (put 'dot-min 'byte-compile 'byte-compile-no-args) ! 517: (put 'dot-min 'byte-opcode 'byte-point-min) ! 518: ! 519: (put 'following-char 'byte-compile 'byte-compile-no-args) ! 520: (put 'following-char 'byte-opcode 'byte-following-char) ! 521: ! 522: (put 'preceding-char 'byte-compile 'byte-compile-no-args) ! 523: (put 'preceding-char 'byte-opcode 'byte-preceding-char) ! 524: ! 525: (put 'current-column 'byte-compile 'byte-compile-no-args) ! 526: (put 'current-column 'byte-opcode 'byte-current-column) ! 527: ! 528: (put 'eolp 'byte-compile 'byte-compile-no-args) ! 529: (put 'eolp 'byte-opcode 'byte-eolp) ! 530: ! 531: (put 'eobp 'byte-compile 'byte-compile-no-args) ! 532: (put 'eobp 'byte-opcode 'byte-eobp) ! 533: ! 534: (put 'bolp 'byte-compile 'byte-compile-no-args) ! 535: (put 'bolp 'byte-opcode 'byte-bolp) ! 536: ! 537: (put 'bobp 'byte-compile 'byte-compile-no-args) ! 538: (put 'bobp 'byte-opcode 'byte-bobp) ! 539: ! 540: (put 'current-buffer 'byte-compile 'byte-compile-no-args) ! 541: (put 'current-buffer 'byte-opcode 'byte-current-buffer) ! 542: ! 543: (put 'read-char 'byte-compile 'byte-compile-no-args) ! 544: (put 'read-char 'byte-opcode 'byte-read-char) ! 545: ! 546: ! 547: (put 'symbolp 'byte-compile 'byte-compile-one-arg) ! 548: (put 'symbolp 'byte-opcode 'byte-symbolp) ! 549: ! 550: (put 'consp 'byte-compile 'byte-compile-one-arg) ! 551: (put 'consp 'byte-opcode 'byte-consp) ! 552: ! 553: (put 'stringp 'byte-compile 'byte-compile-one-arg) ! 554: (put 'stringp 'byte-opcode 'byte-stringp) ! 555: ! 556: (put 'listp 'byte-compile 'byte-compile-one-arg) ! 557: (put 'listp 'byte-opcode 'byte-listp) ! 558: ! 559: (put 'not 'byte-compile 'byte-compile-one-arg) ! 560: (put 'not 'byte-opcode 'byte-not) ! 561: ! 562: (put 'null 'byte-compile 'byte-compile-one-arg) ! 563: (put 'null 'byte-opcode 'byte-not) ! 564: ! 565: (put 'car 'byte-compile 'byte-compile-one-arg) ! 566: (put 'car 'byte-opcode 'byte-car) ! 567: ! 568: (put 'cdr 'byte-compile 'byte-compile-one-arg) ! 569: (put 'cdr 'byte-opcode 'byte-cdr) ! 570: ! 571: (put 'length 'byte-compile 'byte-compile-one-arg) ! 572: (put 'length 'byte-opcode 'byte-length) ! 573: ! 574: (put 'symbol-value 'byte-compile 'byte-compile-one-arg) ! 575: (put 'symbol-value 'byte-opcode 'byte-symbol-value) ! 576: ! 577: (put 'symbol-function 'byte-compile 'byte-compile-one-arg) ! 578: (put 'symbol-function 'byte-opcode 'byte-symbol-function) ! 579: ! 580: (put '1+ 'byte-compile 'byte-compile-one-arg) ! 581: (put '1+ 'byte-opcode 'byte-add1) ! 582: ! 583: (put '1- 'byte-compile 'byte-compile-one-arg) ! 584: (put '1- 'byte-opcode 'byte-sub1) ! 585: ! 586: (put 'goto-char 'byte-compile 'byte-compile-one-arg) ! 587: (put 'goto-char 'byte-opcode 'byte-goto-char) ! 588: ! 589: (put 'char-after 'byte-compile 'byte-compile-one-arg) ! 590: (put 'char-after 'byte-opcode 'byte-char-after) ! 591: ! 592: (put 'set-buffer 'byte-compile 'byte-compile-one-arg) ! 593: (put 'set-buffer 'byte-opcode 'byte-set-buffer) ! 594: ! 595: ;set-mark turns out to be too unimportant for its own opcode. ! 596: ;(put 'set-mark 'byte-compile 'byte-compile-one-arg) ! 597: ;(put 'set-mark 'byte-opcode 'byte-set-mark) ! 598: ! 599: ! 600: (put 'eq 'byte-compile 'byte-compile-two-args) ! 601: (put 'eq 'byte-opcode 'byte-eq) ! 602: (put 'eql 'byte-compile 'byte-compile-two-args) ! 603: (put 'eql 'byte-opcode 'byte-eq) ! 604: ! 605: (put 'memq 'byte-compile 'byte-compile-two-args) ! 606: (put 'memq 'byte-opcode 'byte-memq) ! 607: ! 608: (put 'cons 'byte-compile 'byte-compile-two-args) ! 609: (put 'cons 'byte-opcode 'byte-cons) ! 610: ! 611: (put 'aref 'byte-compile 'byte-compile-two-args) ! 612: (put 'aref 'byte-opcode 'byte-aref) ! 613: ! 614: (put 'set 'byte-compile 'byte-compile-two-args) ! 615: (put 'set 'byte-opcode 'byte-set) ! 616: ! 617: (put 'fset 'byte-compile 'byte-compile-two-args) ! 618: (put 'fset 'byte-opcode 'byte-fset) ! 619: ! 620: (put '= 'byte-compile 'byte-compile-two-args) ! 621: (put '= 'byte-opcode 'byte-eqlsign) ! 622: ! 623: (put '< 'byte-compile 'byte-compile-two-args) ! 624: (put '< 'byte-opcode 'byte-lss) ! 625: ! 626: (put '> 'byte-compile 'byte-compile-two-args) ! 627: (put '> 'byte-opcode 'byte-gtr) ! 628: ! 629: (put '<= 'byte-compile 'byte-compile-two-args) ! 630: (put '<= 'byte-opcode 'byte-leq) ! 631: ! 632: (put '>= 'byte-compile 'byte-compile-two-args) ! 633: (put '>= 'byte-opcode 'byte-geq) ! 634: ! 635: (put 'get 'byte-compile 'byte-compile-two-args) ! 636: (put 'get 'byte-opcode 'byte-get) ! 637: ! 638: (put 'nth 'byte-compile 'byte-compile-two-args) ! 639: (put 'nth 'byte-opcode 'byte-nth) ! 640: ! 641: (put 'aset 'byte-compile 'byte-compile-three-args) ! 642: (put 'aset 'byte-opcode 'byte-aset) ! 643: ! 644: (defun byte-compile-no-args (form) ! 645: (if (/= (length form) 1) ! 646: ;; get run-time wrong-number-of-args error. ! 647: ;; Would be nice if there were some way to do ! 648: ;; compile-time warnings. ! 649: (byte-compile-normal-call form) ! 650: (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0))) ! 651: ! 652: (defun byte-compile-one-arg (form) ! 653: (if (/= (length form) 2) ! 654: (byte-compile-normal-call form) ! 655: (byte-compile-form (car (cdr form))) ;; Push the argument ! 656: (setq byte-compile-depth (1- byte-compile-depth)) ! 657: (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0))) ! 658: ! 659: (defun byte-compile-two-args (form) ! 660: (if (/= (length form) 3) ! 661: (byte-compile-normal-call form) ! 662: (byte-compile-form (car (cdr form))) ;; Push the arguments ! 663: (byte-compile-form (nth 2 form)) ! 664: (setq byte-compile-depth (- byte-compile-depth 2)) ! 665: (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0))) ! 666: ! 667: (defun byte-compile-three-args (form) ! 668: (if (/= (length form) 4) ! 669: (byte-compile-normal-call form) ! 670: (byte-compile-form (car (cdr form))) ;; Push the arguments ! 671: (byte-compile-form (nth 2 form)) ! 672: (byte-compile-form (nth 3 form)) ! 673: (setq byte-compile-depth (- byte-compile-depth 3)) ! 674: (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0))) ! 675: ! 676: (put 'substring 'byte-compile 'byte-compile-substring) ! 677: (defun byte-compile-substring (form) ! 678: (if (or (> (length form) 4) ! 679: (< (length form) 2)) ! 680: (byte-compile-normal-call form) ! 681: (byte-compile-form (nth 1 form)) ! 682: (byte-compile-form (or (nth 2 form) ''nil)) ;Optional arguments ! 683: (byte-compile-form (or (nth 3 form) ''nil)) ! 684: (setq byte-compile-depth (- byte-compile-depth 3)) ! 685: (byte-compile-out byte-substring 0))) ! 686: ! 687: (put 'interactive-p 'byte-compile 'byte-compile-interactive-p) ! 688: (defun byte-compile-interactive-p (form) ! 689: (byte-compile-out byte-interactive-p 0)) ! 690: ! 691: (put 'list 'byte-compile 'byte-compile-list) ! 692: (defun byte-compile-list (form) ! 693: (let ((len (length form))) ! 694: (if (= len 1) ! 695: (byte-compile-constant nil) ! 696: (if (< len 6) ! 697: (let ((args (cdr form))) ! 698: (while args ! 699: (byte-compile-form (car args)) ! 700: (setq args (cdr args))) ! 701: (setq byte-compile-depth (- byte-compile-depth (1- len))) ! 702: (byte-compile-out (symbol-value ! 703: (nth (- len 2) ! 704: '(byte-list1 byte-list2 byte-list3 byte-list4))) ! 705: 0)) ! 706: (byte-compile-normal-call form))))) ! 707: ! 708: (put 'concat 'byte-compile 'byte-compile-concat) ! 709: (defun byte-compile-concat (form) ! 710: (let ((len (length form))) ! 711: (cond ((= len 1) ! 712: (byte-compile-form "")) ! 713: ((= len 2) ! 714: ;; Concat of one arg is not a no-op if arg is not a string. ! 715: (byte-compile-normal-call form)) ! 716: ((< len 6) ! 717: (let ((args (cdr form))) ! 718: (while args ! 719: (byte-compile-form (car args)) ! 720: (setq args (cdr args))) ! 721: (setq byte-compile-depth (- byte-compile-depth (1- len))) ! 722: (byte-compile-out ! 723: (symbol-value (nth (- len 3) ! 724: '(byte-concat2 byte-concat3 byte-concat4))) ! 725: 0))) ! 726: (t ! 727: (byte-compile-normal-call form))))) ! 728: ! 729: (put '- 'byte-compile 'byte-compile-minus) ! 730: (defun byte-compile-minus (form) ! 731: (let ((len (length form))) ! 732: (cond ((= len 2) ! 733: (byte-compile-form (car (cdr form))) ! 734: (setq byte-compile-depth (- byte-compile-depth 1)) ! 735: (byte-compile-out byte-negate 0)) ! 736: ((= len 3) ! 737: (byte-compile-form (car (cdr form))) ! 738: (byte-compile-form (nth 2 form)) ! 739: (setq byte-compile-depth (- byte-compile-depth 2)) ! 740: (byte-compile-out byte-diff 0)) ! 741: (t (byte-compile-normal-call form))))) ! 742: ! 743: (put '+ 'byte-compile 'byte-compile-maybe-two-args) ! 744: (put '+ 'byte-opcode 'byte-plus) ! 745: ! 746: (put 'max 'byte-compile 'byte-compile-maybe-two-args) ! 747: (put 'max 'byte-opcode 'byte-max) ! 748: ! 749: (put 'min 'byte-compile 'byte-compile-maybe-two-args) ! 750: (put 'min 'byte-opcode 'byte-min) ! 751: ! 752: (defun byte-compile-maybe-two-args (form) ! 753: (let ((len (length form))) ! 754: (if (= len 3) ! 755: (progn ! 756: (byte-compile-form (car (cdr form))) ! 757: (byte-compile-form (nth 2 form)) ! 758: (setq byte-compile-depth (- byte-compile-depth 2)) ! 759: (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)) ! 760: (byte-compile-normal-call form)))) ! 761: ! 762: (put 'function 'byte-compile 'byte-compile-function-form) ! 763: (defun byte-compile-function-form (form) ! 764: (cond ((symbolp (car (cdr form))) ! 765: (byte-compile-form ! 766: (list 'symbol-function (list 'quote (nth 1 form))))) ! 767: (t ! 768: (byte-compile-constant (byte-compile-lambda (car (cdr form))))))) ! 769: ! 770: (put 'indent-to 'byte-compile 'byte-compile-indent-to) ! 771: (defun byte-compile-indent-to (form) ! 772: (let ((len (length form))) ! 773: (if (= len 2) ! 774: (progn ! 775: (byte-compile-form (car (cdr form))) ! 776: (setq byte-compile-depth (- byte-compile-depth 1)) ! 777: (byte-compile-out byte-indent-to 0)) ! 778: (byte-compile-normal-call form)))) ! 779: ! 780: (put 'insert 'byte-compile 'byte-compile-insert) ! 781: (defun byte-compile-insert (form) ! 782: (let ((len (length form))) ! 783: (if (< len 3) ! 784: (let ((args (cdr form))) ! 785: (while args ! 786: (byte-compile-form (car args)) ! 787: (setq byte-compile-depth (- byte-compile-depth 1)) ! 788: (byte-compile-out byte-insert 0) ! 789: (setq args (cdr args)))) ! 790: (byte-compile-normal-call form)))) ! 791: ! 792: (put 'setq-default 'byte-compile 'byte-compile-setq-default) ! 793: (defun byte-compile-setq-default (form) ! 794: (byte-compile-form (cons 'set-default (cons (list 'quote (nth 1 form)) ! 795: (nthcdr 2 form))))) ! 796: ! 797: (put 'quote 'byte-compile 'byte-compile-quote) ! 798: (defun byte-compile-quote (form) ! 799: (byte-compile-constant (car (cdr form)))) ! 800: ! 801: (put 'setq 'byte-compile 'byte-compile-setq) ! 802: (defun byte-compile-setq (form) ! 803: (let ((args (cdr form))) ! 804: (if args ! 805: (while args ! 806: (byte-compile-form (car (cdr args))) ! 807: (if (null (cdr (cdr args))) ! 808: (progn ! 809: (byte-compile-out 'byte-dup 0) ! 810: (setq byte-compile-maxdepth (max byte-compile-maxdepth (1+ byte-compile-depth))))) ! 811: (setq byte-compile-depth (1- byte-compile-depth)) ! 812: (byte-compile-variable-ref 'byte-varset (car args)) ! 813: (setq args (cdr (cdr args)))) ! 814: ;; (setq), with no arguments. ! 815: (byte-compile-constant nil)))) ! 816: ! 817: (put 'let 'byte-compile 'byte-compile-let) ! 818: (defun byte-compile-let (form) ! 819: (let ((varlist (car (cdr form)))) ! 820: (while varlist ! 821: (if (symbolp (car varlist)) ! 822: (byte-compile-push-constant nil) ! 823: (byte-compile-form (car (cdr (car varlist))))) ! 824: (setq varlist (cdr varlist)))) ! 825: (let ((varlist (reverse (car (cdr form))))) ! 826: (setq byte-compile-depth (- byte-compile-depth (length varlist))) ! 827: (while varlist ! 828: (if (symbolp (car varlist)) ! 829: (byte-compile-variable-ref 'byte-varbind (car varlist)) ! 830: (byte-compile-variable-ref 'byte-varbind (car (car varlist)))) ! 831: (setq varlist (cdr varlist)))) ! 832: (byte-compile-body (cdr (cdr form))) ! 833: (byte-compile-out 'byte-unbind (length (car (cdr form))))) ! 834: ! 835: (put 'let* 'byte-compile 'byte-compile-let*) ! 836: (defun byte-compile-let* (form) ! 837: (let ((varlist (car (cdr form)))) ! 838: (while varlist ! 839: (if (symbolp (car varlist)) ! 840: (byte-compile-push-constant nil) ! 841: (byte-compile-form (car (cdr (car varlist))))) ! 842: (setq byte-compile-depth (1- byte-compile-depth)) ! 843: (if (symbolp (car varlist)) ! 844: (byte-compile-variable-ref 'byte-varbind (car varlist)) ! 845: (byte-compile-variable-ref 'byte-varbind (car (car varlist)))) ! 846: (setq varlist (cdr varlist)))) ! 847: (byte-compile-body (cdr (cdr form))) ! 848: (byte-compile-out 'byte-unbind (length (car (cdr form))))) ! 849: ! 850: (put 'save-excursion 'byte-compile 'byte-compile-save-excursion) ! 851: (defun byte-compile-save-excursion (form) ! 852: (byte-compile-out 'byte-save-excursion 0) ! 853: (byte-compile-body (cdr form)) ! 854: (byte-compile-out 'byte-unbind 1)) ! 855: ! 856: (put 'save-restriction 'byte-compile 'byte-compile-save-restriction) ! 857: (defun byte-compile-save-restriction (form) ! 858: (byte-compile-out 'byte-save-restriction 0) ! 859: (byte-compile-body (cdr form)) ! 860: (byte-compile-out 'byte-unbind 1)) ! 861: ! 862: (put 'with-output-to-temp-buffer 'byte-compile 'byte-compile-with-output-to-temp-buffer) ! 863: (defun byte-compile-with-output-to-temp-buffer (form) ! 864: (byte-compile-form (car (cdr form))) ! 865: (byte-compile-out 'byte-temp-output-buffer-setup 0) ! 866: (byte-compile-body (cdr (cdr form))) ! 867: (byte-compile-out 'byte-temp-output-buffer-show 0) ! 868: (setq byte-compile-depth (1- byte-compile-depth))) ! 869: ! 870: (put 'progn 'byte-compile 'byte-compile-progn) ! 871: (defun byte-compile-progn (form) ! 872: (byte-compile-body (cdr form))) ! 873: ! 874: (put 'interactive 'byte-compile 'byte-compile-noop) ! 875: (defun byte-compile-noop (form) ! 876: (byte-compile-constant nil)) ! 877: ! 878: (defun byte-compile-body (body) ! 879: (if (null body) ! 880: (byte-compile-constant nil) ! 881: (while body ! 882: (byte-compile-form (car body)) ! 883: (if (cdr body) ! 884: (byte-compile-discard) ! 885: ;; Convention is this will be counted after we return. ! 886: (setq byte-compile-depth (1- byte-compile-depth))) ! 887: (setq body (cdr body))))) ! 888: ! 889: (put 'prog1 'byte-compile 'byte-compile-prog1) ! 890: (defun byte-compile-prog1 (form) ! 891: (byte-compile-form (car (cdr form))) ! 892: (if (cdr (cdr form)) ! 893: (progn ! 894: (byte-compile-body (cdr (cdr form))) ! 895: ;; This discards the value pushed by ..-body ! 896: ;; (which is not counted now in byte-compile-depth) ! 897: ;; and decrements byte-compile-depth for the value ! 898: ;; pushed by byte-compile-form above, which by convention ! 899: ;; will be counted in byte-compile-depth after we return. ! 900: (byte-compile-discard)))) ! 901: ! 902: (put 'prog2 'byte-compile 'byte-compile-prog2) ! 903: (defun byte-compile-prog2 (form) ! 904: (byte-compile-form (car (cdr form))) ! 905: (byte-compile-discard) ! 906: (byte-compile-form (nth 2 form)) ! 907: (if (cdr (cdr (cdr form))) ! 908: (progn ! 909: (byte-compile-body (cdr (cdr (cdr form)))) ! 910: (byte-compile-discard)))) ! 911: ! 912: (defun byte-compile-discard () ! 913: (byte-compile-out 'byte-discard 0) ! 914: (setq byte-compile-depth (1- byte-compile-depth))) ! 915: ! 916: (put 'if 'byte-compile 'byte-compile-if) ! 917: (defun byte-compile-if (form) ! 918: (if (null (nthcdr 3 form)) ! 919: ;; No else-forms ! 920: (let ((donetag (byte-compile-make-tag))) ! 921: (byte-compile-form (car (cdr form))) ! 922: (byte-compile-goto 'byte-goto-if-nil-else-pop donetag) ! 923: (setq byte-compile-depth (1- byte-compile-depth)) ! 924: (byte-compile-form (nth 2 form)) ! 925: (setq byte-compile-depth (1- byte-compile-depth)) ! 926: (byte-compile-out-tag donetag)) ! 927: (let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag))) ! 928: (byte-compile-form (car (cdr form))) ! 929: (byte-compile-goto 'byte-goto-if-nil elsetag) ! 930: (setq byte-compile-depth (1- byte-compile-depth)) ! 931: (byte-compile-form (nth 2 form)) ! 932: (setq byte-compile-depth (1- byte-compile-depth)) ! 933: (byte-compile-goto 'byte-goto donetag) ! 934: (byte-compile-out-tag elsetag) ! 935: (byte-compile-body (cdr (cdr (cdr form)))) ! 936: (byte-compile-out-tag donetag)))) ! 937: ! 938: (put 'cond 'byte-compile 'byte-compile-cond) ! 939: (defun byte-compile-cond (form) ! 940: (if (cdr form) ! 941: (byte-compile-cond-1 (cdr form)) ! 942: (byte-compile-constant nil))) ! 943: (defun byte-compile-cond-1 (clauses) ! 944: (if (or (eq (car (car clauses)) t) ! 945: (eq (car-safe (car (car clauses))) 'quote)) ! 946: ;; Unconditional clause ! 947: (byte-compile-body (cdr (car clauses))) ! 948: (if (null (cdr clauses)) ! 949: ;; Only one clause ! 950: (let ((donetag (byte-compile-make-tag))) ! 951: (byte-compile-form (car (car clauses))) ! 952: (cond ((cdr (car clauses)) ! 953: (byte-compile-goto 'byte-goto-if-nil-else-pop donetag) ! 954: (setq byte-compile-depth (1- byte-compile-depth)) ! 955: (byte-compile-body (cdr (car clauses))) ! 956: (byte-compile-out-tag donetag)))) ! 957: (let ((donetag (byte-compile-make-tag)) ! 958: (elsetag (byte-compile-make-tag))) ! 959: (byte-compile-form (car (car clauses))) ! 960: (if (null (cdr (car clauses))) ! 961: ;; First clause is a singleton. ! 962: (progn ! 963: (byte-compile-goto 'byte-goto-if-not-nil-else-pop donetag) ! 964: (setq byte-compile-depth (1- byte-compile-depth))) ! 965: (byte-compile-goto 'byte-goto-if-nil elsetag) ! 966: (setq byte-compile-depth (1- byte-compile-depth)) ! 967: (byte-compile-body (cdr (car clauses))) ! 968: (byte-compile-goto 'byte-goto donetag) ! 969: (byte-compile-out-tag elsetag)) ! 970: (byte-compile-cond-1 (cdr clauses)) ! 971: (byte-compile-out-tag donetag))))) ! 972: ! 973: (put 'and 'byte-compile 'byte-compile-and) ! 974: (defun byte-compile-and (form) ! 975: (let ((failtag (byte-compile-make-tag)) ! 976: (args (cdr form))) ! 977: (if (null args) ! 978: (progn ! 979: (byte-compile-form t) ! 980: (setq byte-compile-depth (1- byte-compile-depth))) ! 981: (while args ! 982: (byte-compile-form (car args)) ! 983: (setq byte-compile-depth (1- byte-compile-depth)) ! 984: (if (null (cdr args)) ! 985: (byte-compile-out-tag failtag) ! 986: (byte-compile-goto 'byte-goto-if-nil-else-pop failtag)) ! 987: (setq args (cdr args)))))) ! 988: ! 989: (put 'or 'byte-compile 'byte-compile-or) ! 990: (defun byte-compile-or (form) ! 991: (let ((wintag (byte-compile-make-tag)) ! 992: (args (cdr form))) ! 993: (if (null args) ! 994: (byte-compile-constant nil) ! 995: (while args ! 996: (byte-compile-form (car args)) ! 997: (setq byte-compile-depth (1- byte-compile-depth)) ! 998: (if (null (cdr args)) ! 999: (byte-compile-out-tag wintag) ! 1000: (byte-compile-goto 'byte-goto-if-not-nil-else-pop wintag)) ! 1001: (setq args (cdr args)))))) ! 1002: ! 1003: (put 'while 'byte-compile 'byte-compile-while) ! 1004: (defun byte-compile-while (form) ! 1005: (let ((endtag (byte-compile-make-tag)) ! 1006: (looptag (byte-compile-make-tag)) ! 1007: (args (cdr (cdr form)))) ! 1008: (byte-compile-out-tag looptag) ! 1009: (byte-compile-form (car (cdr form))) ! 1010: (byte-compile-goto 'byte-goto-if-nil-else-pop endtag) ! 1011: (byte-compile-body (cdr (cdr form))) ! 1012: (byte-compile-discard) ! 1013: (byte-compile-goto 'byte-goto looptag) ! 1014: (byte-compile-out-tag endtag))) ! 1015: ! 1016: (put 'catch 'byte-compile 'byte-compile-catch) ! 1017: (defun byte-compile-catch (form) ! 1018: (byte-compile-form (car (cdr form))) ! 1019: (byte-compile-push-constant (byte-compile-top-level (cons 'progn (cdr (cdr form))))) ! 1020: (setq byte-compile-depth (- byte-compile-depth 2)) ! 1021: (byte-compile-out 'byte-catch 0)) ! 1022: ! 1023: (put 'save-window-excursion 'byte-compile 'byte-compile-save-window-excursion) ! 1024: (defun byte-compile-save-window-excursion (form) ! 1025: (byte-compile-push-constant ! 1026: (list (byte-compile-top-level (cons 'progn (cdr form))))) ! 1027: (setq byte-compile-depth (1- byte-compile-depth)) ! 1028: (byte-compile-out 'byte-save-window-excursion 0)) ! 1029: ! 1030: (put 'unwind-protect 'byte-compile 'byte-compile-unwind-protect) ! 1031: (defun byte-compile-unwind-protect (form) ! 1032: (byte-compile-push-constant ! 1033: (list (byte-compile-top-level (cons 'progn (cdr (cdr form)))))) ! 1034: (setq byte-compile-depth (1- byte-compile-depth)) ! 1035: (byte-compile-out 'byte-unwind-protect 0) ! 1036: (byte-compile-form (car (cdr form))) ! 1037: (setq byte-compile-depth (1- byte-compile-depth)) ! 1038: (byte-compile-out 'byte-unbind 1)) ! 1039: ! 1040: (put 'condition-case 'byte-compile 'byte-compile-condition-case) ! 1041: (defun byte-compile-condition-case (form) ! 1042: (byte-compile-push-constant (car (cdr form))) ! 1043: (byte-compile-push-constant (byte-compile-top-level (nth 2 form))) ! 1044: (let ((clauses (cdr (cdr (cdr form)))) ! 1045: compiled-clauses) ! 1046: (while clauses ! 1047: (let ((clause (car clauses))) ! 1048: (setq compiled-clauses ! 1049: (cons (list (car clause) ! 1050: (byte-compile-top-level (cons 'progn (cdr clause)))) ! 1051: compiled-clauses))) ! 1052: (setq clauses (cdr clauses))) ! 1053: (byte-compile-push-constant (nreverse compiled-clauses))) ! 1054: (setq byte-compile-depth (- byte-compile-depth 3)) ! 1055: (byte-compile-out 'byte-condition-case 0)) ! 1056: ! 1057: (defun byte-compile-make-tag () ! 1058: (cons nil nil)) ! 1059: ! 1060: (defun byte-compile-out-tag (tag) ! 1061: (let ((uses (car tag))) ! 1062: (setcar tag byte-compile-pc) ! 1063: (while uses ! 1064: (byte-compile-store-goto (car uses) byte-compile-pc) ! 1065: (setq uses (cdr uses))))) ! 1066: ! 1067: (defun byte-compile-goto (opcode tag) ! 1068: (byte-compile-out opcode 0) ! 1069: (if (integerp (car tag)) ! 1070: (byte-compile-store-goto byte-compile-pc (car tag)) ! 1071: (setcar tag (cons byte-compile-pc (car tag)))) ! 1072: (setq byte-compile-pc (+ byte-compile-pc 2))) ! 1073: ! 1074: (defun byte-compile-store-goto (at-pc to-pc) ! 1075: (setq byte-compile-output ! 1076: (cons (cons at-pc (logand to-pc 255)) ! 1077: byte-compile-output)) ! 1078: (setq byte-compile-output ! 1079: (cons (cons (1+ at-pc) (lsh to-pc -8)) ! 1080: byte-compile-output))) ! 1081: ! 1082: (defun byte-compile-out (opcode offset) ! 1083: (setq opcode (eval opcode)) ! 1084: (if (< offset 6) ! 1085: (byte-compile-out-1 (+ opcode offset)) ! 1086: (if (< offset 256) ! 1087: (progn ! 1088: (byte-compile-out-1 (+ opcode 6)) ! 1089: (byte-compile-out-1 offset)) ! 1090: (byte-compile-out-1 (+ opcode 7)) ! 1091: (byte-compile-out-1 (logand offset 255)) ! 1092: (byte-compile-out-1 (lsh offset -8))))) ! 1093: ! 1094: (defun byte-compile-out-const (offset) ! 1095: (if (< offset byte-constant-limit) ! 1096: (byte-compile-out-1 (+ byte-constant offset)) ! 1097: (byte-compile-out-1 byte-constant2) ! 1098: (byte-compile-out-1 (logand offset 255)) ! 1099: (byte-compile-out-1 (lsh offset -8)))) ! 1100: ! 1101: (defun byte-compile-out-1 (code) ! 1102: (setq byte-compile-output ! 1103: (cons (cons byte-compile-pc code) ! 1104: byte-compile-output)) ! 1105: (setq byte-compile-pc (1+ byte-compile-pc))) ! 1106: ! 1107: ;;; by [email protected] ! 1108: ;;; Only works noninteractively. ! 1109: (defun batch-byte-compile () ! 1110: "Runs byte-compile-file on the files remaining on the command line. ! 1111: Must be used only with -batch, and kills emacs on completion. ! 1112: Each file will be processed even if an error occurred previously. ! 1113: For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\"" ! 1114: ;; command-line-args-left is what is left of the command line (from startup.el) ! 1115: (if (not noninteractive) ! 1116: (error "batch-byte-compile is to be used only with -batch")) ! 1117: (let ((error nil)) ! 1118: (while command-line-args-left ! 1119: (if (file-directory-p (expand-file-name (car command-line-args-left))) ! 1120: (let ((files (directory-files (car command-line-args-left))) ! 1121: source dest) ! 1122: (while files ! 1123: (if (and (string-match ".el$" (car files)) ! 1124: (not (auto-save-file-name-p (car files))) ! 1125: (setq source (expand-file-name (car files) ! 1126: (car command-line-args-left))) ! 1127: (setq dest (concat (file-name-sans-versions source) "c")) ! 1128: (file-exists-p dest) ! 1129: (file-newer-than-file-p source dest)) ! 1130: (if (null (batch-byte-compile-file source)) ! 1131: (setq error t))) ! 1132: (setq files (cdr files)))) ! 1133: (if (null (batch-byte-compile-file (car command-line-args-left))) ! 1134: (setq error t))) ! 1135: (setq command-line-args-left (cdr command-line-args-left))) ! 1136: (message "Done") ! 1137: (kill-emacs (if error 1 0)))) ! 1138: ! 1139: (defun batch-byte-compile-file (file) ! 1140: (condition-case err ! 1141: (progn (byte-compile-file file) t) ! 1142: (error ! 1143: (message (if (cdr err) ! 1144: ">>Error occurred processing %s: %s (%s)" ! 1145: ">>Error occurred processing %s: %s") ! 1146: file ! 1147: (get (car err) 'error-message) ! 1148: (prin1-to-string (cdr err))) ! 1149: nil)))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.