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