![[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] / 43BSD / contrib / emacs / lisp|
Return to bytecomp.el CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp |
1.1 ! root 1: ;; Compilation of Lisp code into byte code. ! 2: ;; Copyright (C) 1985 Richard M. Stallman. ! 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: ! 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) ! 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) ! 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) ! 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)) ! 188: (count 0) ! 189: source) ! 190: (while files ! 191: (if (and (string-match ".el$" (car files)) ! 192: (not (auto-save-file-name-p (car files))) ! 193: (setq source (expand-file-name (car files) directory)) ! 194: (if (file-exists-p (concat source "c")) ! 195: (file-newer-than-file-p source (concat source "c")) ! 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 file-newer-than-file-p (file1 file2) ! 204: "Return t if FILE1 modified more recently than FILE2." ! 205: (let ((mtime1 (car (nthcdr 5 (file-attributes file1)))) ! 206: (mtime2 (car (nthcdr 5 (file-attributes file2))))) ! 207: (or (> (car mtime1) (car mtime2)) ! 208: (and (= (car mtime1) (car mtime2)) ! 209: (> (car (cdr mtime1)) (car (cdr mtime2))))))) ! 210: ! 211: (defun byte-compile-file (filename) ! 212: "Compile a file of Lisp code named FILENAME into a file of byte code. ! 213: The output file's name is made by appending \"c\" to the end of FILENAME." ! 214: (interactive "fByte compile file: ") ! 215: ;; Expand now so we get the current buffer's defaults ! 216: (setq filename (expand-file-name filename)) ! 217: (message "Compiling %s..." filename) ! 218: (let ((inbuffer (get-buffer-create " *Compiler Input*")) ! 219: (outbuffer (get-buffer-create " *Compiler Output*")) ! 220: (byte-compile-macro-environment nil) ! 221: ! 222: (case-fold-search nil) ;I thought this was lisp, not unix! ! 223: sexp) ! 224: (save-excursion ! 225: (set-buffer inbuffer) ! 226: (erase-buffer) ! 227: (insert-file-contents filename) ! 228: (goto-char 1) ! 229: (set-buffer outbuffer) ! 230: (emacs-lisp-mode) ! 231: (erase-buffer) ! 232: (while (save-excursion ! 233: (set-buffer inbuffer) ! 234: (while (progn (skip-chars-forward " \t\n\^l") ! 235: (looking-at ";")) ! 236: (forward-line 1)) ! 237: (not (eobp))) ! 238: (setq sexp (read inbuffer)) ! 239: (print (byte-compile-file-form sexp) outbuffer)) ! 240: (set-buffer outbuffer) ! 241: (goto-char 1) ! 242: (while (search-forward "\n(" nil t) ! 243: (cond ((looking-at "defun \\|autoload ") ! 244: (forward-sexp 3) ! 245: (skip-chars-forward " ") ! 246: (if (looking-at "\"") ! 247: (progn (forward-char 1) ! 248: (insert "\\\n")))))) ! 249: (write-region 1 (point-max) (concat filename "c")) ! 250: (kill-buffer (current-buffer)) ! 251: (kill-buffer inbuffer))) ! 252: t) ! 253: ! 254: ! 255: (defun byte-compile-file-form (form) ! 256: (if (memq (car-safe form) '(defun defmacro)) ! 257: (let* ((name (car (cdr form))) ! 258: (tem (assq name byte-compile-macro-environment))) ! 259: (if (eq (car form) 'defun) ! 260: (progn ! 261: (message "Compiling %s (%s)..." filename (nth 1 form)) ! 262: (cond (tem (setcdr tem nil)) ! 263: ((and (fboundp name) ! 264: (eq (car-safe (symbol-function name)) 'macro)) ! 265: ;; shadow existing macro definition ! 266: (setq byte-compile-macro-environment ! 267: (cons (cons name nil) ! 268: byte-compile-macro-environment)))) ! 269: (prog1 (cons 'defun (byte-compile-lambda (cdr form))) ! 270: (if (not noninteractive) ! 271: (message "Compiling %s..." filename)))) ! 272: ;; defmacro ! 273: (if tem ! 274: (setcdr tem (cons 'lambda (cdr (cdr form)))) ! 275: (setq byte-compile-macro-environment ! 276: (cons (cons name (cons 'lambda (cdr (cdr form)))) ! 277: byte-compile-macro-environment))) ! 278: (cons 'defmacro (byte-compile-lambda (cdr form))))) ! 279: form)) ! 280: ! 281: (defun byte-compile (funname) ! 282: "Byte-compile the definition of function FUNNAME (a symbol)." ! 283: (if (and (fboundp funname) ! 284: (eq (car-safe (symbol-function funname)) 'lambda)) ! 285: (fset funname (byte-compile-lambda (symbol-function funname))))) ! 286: ! 287: (defun byte-compile-lambda (fun) ! 288: (let* ((bodyptr (cdr fun)) ! 289: (int (assq 'interactive (cdr bodyptr))) ! 290: newbody) ! 291: ;; Skip doc string. ! 292: (if (stringp (car (cdr bodyptr))) ! 293: (setq bodyptr (cdr bodyptr))) ! 294: (setq newbody (list (byte-compile-top-level ! 295: (cons 'progn (cdr bodyptr))))) ! 296: (if int ! 297: (setq newbody (cons (if (or (stringp (car (cdr int))) ! 298: (null (car (cdr int)))) ! 299: int ! 300: (list 'interactive ! 301: (byte-compile-top-level (car (cdr int))))) ! 302: newbody))) ! 303: (if (not (eq bodyptr (cdr fun))) ! 304: (setq newbody (cons (nth 2 fun) newbody))) ! 305: (cons (car fun) (cons (car (cdr fun)) newbody)))) ! 306: ! 307: (defun byte-compile-top-level (form) ! 308: (let ((byte-compile-constants nil) ! 309: (byte-compile-constnum nil) ! 310: (byte-compile-pc 0) ! 311: (byte-compile-depth 0) ! 312: (byte-compile-maxdepth 0) ! 313: (byte-compile-output nil) ! 314: (byte-compile-string nil) ! 315: (byte-compile-vector nil)) ! 316: (let ((vars (nreverse (byte-compile-find-vars form))) ! 317: (i -1)) ! 318: (while vars ! 319: (setq i (1+ i)) ! 320: (setq byte-compile-constants (cons (cons (car vars) i) ! 321: byte-compile-constants)) ! 322: (setq vars (cdr vars))) ! 323: (setq byte-compile-constnum i)) ! 324: (byte-compile-form form) ! 325: (byte-compile-out 'byte-return 0) ! 326: (setq byte-compile-vector (make-vector (1+ byte-compile-constnum) ! 327: nil)) ! 328: (while byte-compile-constants ! 329: (aset byte-compile-vector (cdr (car byte-compile-constants)) ! 330: (car (car byte-compile-constants))) ! 331: (setq byte-compile-constants (cdr byte-compile-constants))) ! 332: (setq byte-compile-string (make-string byte-compile-pc 0)) ! 333: (while byte-compile-output ! 334: (aset byte-compile-string (car (car byte-compile-output)) ! 335: (cdr (car byte-compile-output))) ! 336: (setq byte-compile-output (cdr byte-compile-output))) ! 337: (list 'byte-code byte-compile-string ! 338: byte-compile-vector byte-compile-maxdepth))) ! 339: ! 340: (defun byte-compile-find-vars (form) ! 341: (let ((all-vars nil)) ! 342: (byte-compile-find-vars-1 form) ! 343: all-vars)) ! 344: ! 345: (defun byte-compile-find-vars-1 (form) ! 346: (cond ((symbolp form) ! 347: (if (not (memq form all-vars)) ! 348: (setq all-vars (cons form all-vars)))) ! 349: ((or (not (consp form)) (eq (car form) 'quote)) ! 350: nil) ! 351: ((memq (car form) '(let let*)) ! 352: (let ((binds (car (cdr form))) ! 353: (body (cdr (cdr form)))) ! 354: (while binds ! 355: (if (symbolp (car binds)) ! 356: (if (not (memq (car binds) all-vars)) ! 357: (setq all-vars (cons (car binds) all-vars))) ! 358: (if (consp (car binds)) ! 359: (progn ! 360: (if (not (memq (car (car binds)) all-vars)) ! 361: (setq all-vars (cons (car (car binds)) all-vars))) ! 362: (byte-compile-find-vars-1 (car (cdr (car binds))))))) ! 363: (setq binds (cdr binds))) ! 364: (while body ! 365: (byte-compile-find-vars-1 (car body)) ! 366: (setq body (cdr body))))) ! 367: ((eq (car form) 'cond) ! 368: (let ((clauses (cdr form))) ! 369: (while clauses ! 370: (let ((body (car clauses))) ! 371: (while body ! 372: (byte-compile-find-vars-1 (car body)) ! 373: (setq body (cdr body)))) ! 374: (setq clauses (cdr clauses))))) ! 375: ((not (eq form (setq form (macroexpand form byte-compile-macro-environment)))) ! 376: (byte-compile-find-vars-1 form)) ! 377: (t ! 378: (let ((body (if (symbolp (car form)) (cdr form) form))) ! 379: (while body ! 380: (byte-compile-find-vars-1 (car body)) ! 381: (setq body (cdr body))))))) ! 382: ! 383: ;; This is the recursive entry point for compiling each subform of an expression. ! 384: ! 385: ;; Note that handler functions SHOULD NOT increment byte-compile-depth ! 386: ;; for the values they are returning! That is done on return here. ! 387: ;; Handlers should make sure that the depth on exit is the same as ! 388: ;; it was when the handler was called. ! 389: ! 390: (defun byte-compile-form (form) ! 391: (setq form (macroexpand form byte-compile-macro-environment)) ! 392: (if (symbolp form) ! 393: (byte-compile-variable-ref 'byte-varref form) ! 394: (if (not (consp form)) ! 395: (byte-compile-constant form) ! 396: (let ((handler (get (car form) 'byte-compile))) ! 397: (if handler ! 398: (funcall handler form) ! 399: (byte-compile-push-constant (car form)) ! 400: (let ((copy (cdr form))) ! 401: (while copy (byte-compile-form (car copy)) (setq copy (cdr copy)))) ! 402: (byte-compile-out 'byte-call (length (cdr form))) ! 403: (setq byte-compile-depth (- byte-compile-depth (length (cdr form)))))))) ! 404: (setq byte-compile-maxdepth ! 405: (max byte-compile-maxdepth ! 406: (setq byte-compile-depth (1+ byte-compile-depth))))) ! 407: ! 408: (defun byte-compile-variable-ref (base-op var) ! 409: (let ((data (assq var byte-compile-constants))) ! 410: (if data ! 411: (byte-compile-out base-op (cdr data)) ! 412: (error (format "Variable %s seen on pass 2 of byte compiler but not pass 1" ! 413: (prin1-to-string var)))))) ! 414: ! 415: ;; Use this when the value of a form is a constant, ! 416: ;; because byte-compile-depth will be incremented accordingly ! 417: ;; on return to byte-compile-form, so it should not be done by the handler. ! 418: (defun byte-compile-constant (const) ! 419: (let ((data (if (stringp const) ! 420: (assoc const byte-compile-constants) ! 421: (assq const byte-compile-constants)))) ! 422: (if data ! 423: (byte-compile-out-const (cdr data)) ! 424: (setq byte-compile-constants ! 425: (cons (cons const (setq byte-compile-constnum (1+ byte-compile-constnum))) ! 426: byte-compile-constants)) ! 427: (byte-compile-out-const byte-compile-constnum)))) ! 428: ! 429: ;; Use this for a constant that is not the value of its containing form. ! 430: ;; Note that the calling function must explicitly decrement byte-compile-depth ! 431: ;; (or perhaps call byte-compile-discard to do so) ! 432: ;; for the word pushed by this function. ! 433: (defun byte-compile-push-constant (const) ! 434: (byte-compile-constant const) ! 435: (setq byte-compile-maxdepth ! 436: (max byte-compile-maxdepth ! 437: (setq byte-compile-depth (1+ byte-compile-depth))))) ! 438: ! 439: ;; Compile those primitive ordinary functions ! 440: ;; which have special byte codes just for speed. ! 441: ! 442: (put 'point 'byte-compile 'byte-compile-no-args) ! 443: (put 'point 'byte-opcode 'byte-point) ! 444: ! 445: (put 'dot 'byte-compile 'byte-compile-no-args) ! 446: (put 'dot 'byte-opcode 'byte-point) ! 447: ! 448: (put 'mark 'byte-compile 'byte-compile-no-args) ! 449: (put 'mark 'byte-opcode 'byte-mark) ! 450: ! 451: (put 'point-max 'byte-compile 'byte-compile-no-args) ! 452: (put 'point-max 'byte-opcode 'byte-point-max) ! 453: ! 454: (put 'point-min 'byte-compile 'byte-compile-no-args) ! 455: (put 'point-min 'byte-opcode 'byte-point-min) ! 456: ! 457: (put 'dot-max 'byte-compile 'byte-compile-no-args) ! 458: (put 'dot-max 'byte-opcode 'byte-point-max) ! 459: ! 460: (put 'dot-min 'byte-compile 'byte-compile-no-args) ! 461: (put 'dot-min 'byte-opcode 'byte-point-min) ! 462: ! 463: (put 'following-char 'byte-compile 'byte-compile-no-args) ! 464: (put 'following-char 'byte-opcode 'byte-following-char) ! 465: ! 466: (put 'preceding-char 'byte-compile 'byte-compile-no-args) ! 467: (put 'preceding-char 'byte-opcode 'byte-preceding-char) ! 468: ! 469: (put 'current-column 'byte-compile 'byte-compile-no-args) ! 470: (put 'current-column 'byte-opcode 'byte-current-column) ! 471: ! 472: (put 'eolp 'byte-compile 'byte-compile-no-args) ! 473: (put 'eolp 'byte-opcode 'byte-eolp) ! 474: ! 475: (put 'eobp 'byte-compile 'byte-compile-no-args) ! 476: (put 'eobp 'byte-opcode 'byte-eobp) ! 477: ! 478: (put 'bolp 'byte-compile 'byte-compile-no-args) ! 479: (put 'bolp 'byte-opcode 'byte-bolp) ! 480: ! 481: (put 'bobp 'byte-compile 'byte-compile-no-args) ! 482: (put 'bobp 'byte-opcode 'byte-bobp) ! 483: ! 484: (put 'current-buffer 'byte-compile 'byte-compile-no-args) ! 485: (put 'current-buffer 'byte-opcode 'byte-current-buffer) ! 486: ! 487: (put 'read-char 'byte-compile 'byte-compile-no-args) ! 488: (put 'read-char 'byte-opcode 'byte-read-char) ! 489: ! 490: ! 491: (put 'symbolp 'byte-compile 'byte-compile-one-arg) ! 492: (put 'symbolp 'byte-opcode 'byte-symbolp) ! 493: ! 494: (put 'consp 'byte-compile 'byte-compile-one-arg) ! 495: (put 'consp 'byte-opcode 'byte-consp) ! 496: ! 497: (put 'stringp 'byte-compile 'byte-compile-one-arg) ! 498: (put 'stringp 'byte-opcode 'byte-stringp) ! 499: ! 500: (put 'listp 'byte-compile 'byte-compile-one-arg) ! 501: (put 'listp 'byte-opcode 'byte-listp) ! 502: ! 503: (put 'not 'byte-compile 'byte-compile-one-arg) ! 504: (put 'not 'byte-opcode 'byte-not) ! 505: ! 506: (put 'null 'byte-compile 'byte-compile-one-arg) ! 507: (put 'null 'byte-opcode 'byte-not) ! 508: ! 509: (put 'car 'byte-compile 'byte-compile-one-arg) ! 510: (put 'car 'byte-opcode 'byte-car) ! 511: ! 512: (put 'cdr 'byte-compile 'byte-compile-one-arg) ! 513: (put 'cdr 'byte-opcode 'byte-cdr) ! 514: ! 515: (put 'length 'byte-compile 'byte-compile-one-arg) ! 516: (put 'length 'byte-opcode 'byte-length) ! 517: ! 518: (put 'symbol-value 'byte-compile 'byte-compile-one-arg) ! 519: (put 'symbol-value 'byte-opcode 'byte-symbol-value) ! 520: ! 521: (put 'symbol-function 'byte-compile 'byte-compile-one-arg) ! 522: (put 'symbol-function 'byte-opcode 'byte-symbol-function) ! 523: ! 524: (put '1+ 'byte-compile 'byte-compile-one-arg) ! 525: (put '1+ 'byte-opcode 'byte-add1) ! 526: ! 527: (put '1- 'byte-compile 'byte-compile-one-arg) ! 528: (put '1- 'byte-opcode 'byte-sub1) ! 529: ! 530: (put 'goto-char 'byte-compile 'byte-compile-one-arg) ! 531: (put 'goto-char 'byte-opcode 'byte-goto-char) ! 532: ! 533: (put 'char-after 'byte-compile 'byte-compile-one-arg) ! 534: (put 'char-after 'byte-opcode 'byte-char-after) ! 535: ! 536: (put 'set-buffer 'byte-compile 'byte-compile-one-arg) ! 537: (put 'set-buffer 'byte-opcode 'byte-set-buffer) ! 538: ! 539: (put 'set-mark 'byte-compile 'byte-compile-one-arg) ! 540: (put 'set-mark 'byte-opcode 'byte-set-mark) ! 541: ! 542: (put 'interactive-p 'byte-compile 'byte-compile-one-arg) ! 543: (put 'interactive-p 'byte-opcode 'byte-interactive-p) ! 544: ! 545: ! 546: (put 'eq 'byte-compile 'byte-compile-two-args) ! 547: (put 'eq 'byte-opcode 'byte-eq) ! 548: ! 549: (put 'memq 'byte-compile 'byte-compile-two-args) ! 550: (put 'memq 'byte-opcode 'byte-memq) ! 551: ! 552: (put 'cons 'byte-compile 'byte-compile-two-args) ! 553: (put 'cons 'byte-opcode 'byte-cons) ! 554: ! 555: (put 'aref 'byte-compile 'byte-compile-two-args) ! 556: (put 'aref 'byte-opcode 'byte-aref) ! 557: ! 558: (put 'set 'byte-compile 'byte-compile-two-args) ! 559: (put 'set 'byte-opcode 'byte-set) ! 560: ! 561: (put 'fset 'byte-compile 'byte-compile-two-args) ! 562: (put 'fset 'byte-opcode 'byte-fset) ! 563: ! 564: (put '= 'byte-compile 'byte-compile-two-args) ! 565: (put '= 'byte-opcode 'byte-eqlsign) ! 566: ! 567: (put '< 'byte-compile 'byte-compile-two-args) ! 568: (put '< 'byte-opcode 'byte-lss) ! 569: ! 570: (put '> 'byte-compile 'byte-compile-two-args) ! 571: (put '> 'byte-opcode 'byte-gtr) ! 572: ! 573: (put '<= 'byte-compile 'byte-compile-two-args) ! 574: (put '<= 'byte-opcode 'byte-leq) ! 575: ! 576: (put '>= 'byte-compile 'byte-compile-two-args) ! 577: (put '>= 'byte-opcode 'byte-geq) ! 578: ! 579: (put 'get 'byte-compile 'byte-compile-two-args) ! 580: (put 'get 'byte-opcode 'byte-get) ! 581: ! 582: (put 'nth 'byte-compile 'byte-compile-two-args) ! 583: (put 'nth 'byte-opcode 'byte-nth) ! 584: ! 585: (put 'aset 'byte-compile 'byte-compile-three-args) ! 586: (put 'aset 'byte-opcode 'byte-aset) ! 587: ! 588: (put 'substring 'byte-compile 'byte-compile-three-args) ! 589: (put 'substring 'byte-opcode 'byte-substring) ! 590: ! 591: (put 'scan-buffer 'byte-compile 'byte-compile-three-args) ! 592: (put 'scan-buffer 'byte-opcode 'byte-scan-buffer) ! 593: ! 594: (defun byte-compile-no-args (form) ! 595: (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)) ! 596: ! 597: (defun byte-compile-one-arg (form) ! 598: (byte-compile-form (or (car (cdr form)) ''nil)) ;; Push the argument ! 599: (setq byte-compile-depth (1- byte-compile-depth)) ! 600: (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)) ! 601: ! 602: (defun byte-compile-two-args (form) ! 603: (byte-compile-form (or (car (cdr form)) ''nil)) ;; Push the arguments ! 604: (byte-compile-form (or (nth 2 form) ''nil)) ! 605: (setq byte-compile-depth (- byte-compile-depth 2)) ! 606: (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)) ! 607: ! 608: (defun byte-compile-three-args (form) ! 609: (byte-compile-form (or (car (cdr form)) ''nil)) ;; Push the arguments ! 610: (byte-compile-form (or (nth 2 form) ''nil)) ! 611: (byte-compile-form (or (nth 3 form) ''nil)) ! 612: (setq byte-compile-depth (- byte-compile-depth 3)) ! 613: (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)) ! 614: ! 615: (put 'list 'byte-compile 'byte-compile-list) ! 616: (defun byte-compile-list (form) ! 617: (let ((len (length form))) ! 618: (if (= len 1) ! 619: (byte-compile-constant nil) ! 620: (if (< len 6) ! 621: (let ((args (cdr form))) ! 622: (while args ! 623: (byte-compile-form (car args)) ! 624: (setq args (cdr args))) ! 625: (setq byte-compile-depth (- byte-compile-depth (1- len))) ! 626: (byte-compile-out (symbol-value ! 627: (nth (- len 2) ! 628: '(byte-list1 byte-list2 byte-list3 byte-list4))) ! 629: 0)) ! 630: (byte-compile-normal-call form))))) ! 631: ! 632: (put 'concat 'byte-compile 'byte-compile-concat) ! 633: (defun byte-compile-concat (form) ! 634: (let ((len (length form))) ! 635: (cond ((= len 1) ! 636: (byte-compile-form "")) ! 637: ((= len 2) ! 638: ;; Concat of one arg is not a no-op if arg is not a string. ! 639: (byte-compile-normal-call form)) ! 640: ((< len 6) ! 641: (let ((args (cdr form))) ! 642: (while args ! 643: (byte-compile-form (car args)) ! 644: (setq args (cdr args))) ! 645: (setq byte-compile-depth (- byte-compile-depth (1- len))) ! 646: (byte-compile-out ! 647: (symbol-value (nth (- len 3) ! 648: '(byte-concat2 byte-concat3 byte-concat4))) ! 649: 0))) ! 650: (t ! 651: (byte-compile-normal-call form))))) ! 652: ! 653: (put '- 'byte-compile 'byte-compile-minus) ! 654: (defun byte-compile-minus (form) ! 655: (let ((len (length form))) ! 656: (cond ((= len 2) ! 657: (byte-compile-form (car (cdr form))) ! 658: (setq byte-compile-depth (- byte-compile-depth 1)) ! 659: (byte-compile-out byte-negate 0)) ! 660: ((= len 3) ! 661: (byte-compile-form (car (cdr form))) ! 662: (byte-compile-form (nth 2 form)) ! 663: (setq byte-compile-depth (- byte-compile-depth 2)) ! 664: (byte-compile-out byte-diff 0)) ! 665: (t (byte-compile-normal-call form))))) ! 666: ! 667: (put '+ 'byte-compile 'byte-compile-maybe-two-args) ! 668: (put '+ 'byte-opcode 'byte-plus) ! 669: ! 670: (put 'max 'byte-compile 'byte-compile-maybe-two-args) ! 671: (put 'max 'byte-opcode 'byte-max) ! 672: ! 673: (put 'min 'byte-compile 'byte-compile-maybe-two-args) ! 674: (put 'min 'byte-opcode 'byte-min) ! 675: ! 676: (defun byte-compile-maybe-two-args (form) ! 677: (let ((len (length form))) ! 678: (if (= len 3) ! 679: (progn ! 680: (byte-compile-form (car (cdr form))) ! 681: (byte-compile-form (nth 2 form)) ! 682: (setq byte-compile-depth (- byte-compile-depth 2)) ! 683: (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)) ! 684: (byte-compile-normal-call form)))) ! 685: ! 686: (defun byte-compile-normal-call (form) ! 687: (byte-compile-push-constant (car form)) ! 688: (let ((copy (cdr form))) ! 689: (while copy (byte-compile-form (car copy)) (setq copy (cdr copy)))) ! 690: (byte-compile-out 'byte-call (length (cdr form))) ! 691: (setq byte-compile-depth (- byte-compile-depth (length (cdr form))))) ! 692: ! 693: (put 'function 'byte-compile 'byte-compile-function-form) ! 694: (defun byte-compile-function-form (form) ! 695: (byte-compile-constant (byte-compile-lambda (car (cdr form))))) ! 696: ! 697: (put 'indent-to 'byte-compile 'byte-compile-indent-to) ! 698: (defun byte-compile-indent-to (form) ! 699: (let ((len (length form))) ! 700: (if (= len 2) ! 701: (progn ! 702: (byte-compile-form (car (cdr form))) ! 703: (setq byte-compile-depth (- byte-compile-depth 1)) ! 704: (byte-compile-out byte-indent-to 0)) ! 705: (byte-compile-normal-call form)))) ! 706: ! 707: (put 'insert 'byte-compile 'byte-compile-insert) ! 708: (defun byte-compile-insert (form) ! 709: (let ((len (length form))) ! 710: (if (< len 3) ! 711: (let ((args (cdr form))) ! 712: (while args ! 713: (byte-compile-form (car args)) ! 714: (setq byte-compile-depth (- byte-compile-depth 1)) ! 715: (byte-compile-out byte-insert 0) ! 716: (setq args (cdr args)))) ! 717: (byte-compile-normal-call form)))) ! 718: ! 719: (put 'quote 'byte-compile 'byte-compile-quote) ! 720: (defun byte-compile-quote (form) ! 721: (byte-compile-constant (car (cdr form)))) ! 722: ! 723: (put 'setq 'byte-compile 'byte-compile-setq) ! 724: (defun byte-compile-setq (form) ! 725: (let ((args (cdr form))) ! 726: (while args ! 727: (byte-compile-form (car (cdr args))) ! 728: (if (null (cdr (cdr args))) ! 729: (progn ! 730: (byte-compile-out 'byte-dup 0) ! 731: (setq byte-compile-maxdepth (max byte-compile-maxdepth (1+ byte-compile-depth))))) ! 732: (setq byte-compile-depth (1- byte-compile-depth)) ! 733: (byte-compile-variable-ref 'byte-varset (car args)) ! 734: (setq args (cdr (cdr args)))))) ! 735: ! 736: (put 'let 'byte-compile 'byte-compile-let) ! 737: (defun byte-compile-let (form) ! 738: (let ((varlist (car (cdr form)))) ! 739: (while varlist ! 740: (if (symbolp (car varlist)) ! 741: (byte-compile-push-constant nil) ! 742: (byte-compile-form (car (cdr (car varlist))))) ! 743: (setq varlist (cdr varlist)))) ! 744: (let ((varlist (reverse (car (cdr form))))) ! 745: (setq byte-compile-depth (- byte-compile-depth (length varlist))) ! 746: (while varlist ! 747: (if (symbolp (car varlist)) ! 748: (byte-compile-variable-ref 'byte-varbind (car varlist)) ! 749: (byte-compile-variable-ref 'byte-varbind (car (car varlist)))) ! 750: (setq varlist (cdr varlist)))) ! 751: (byte-compile-body (cdr (cdr form))) ! 752: (byte-compile-out 'byte-unbind (length (car (cdr form))))) ! 753: ! 754: (put 'let* 'byte-compile 'byte-compile-let*) ! 755: (defun byte-compile-let* (form) ! 756: (let ((varlist (car (cdr form)))) ! 757: (while varlist ! 758: (if (symbolp (car varlist)) ! 759: (byte-compile-push-constant nil) ! 760: (byte-compile-form (car (cdr (car varlist))))) ! 761: (setq byte-compile-depth (1- byte-compile-depth)) ! 762: (if (symbolp (car varlist)) ! 763: (byte-compile-variable-ref 'byte-varbind (car varlist)) ! 764: (byte-compile-variable-ref 'byte-varbind (car (car varlist)))) ! 765: (setq varlist (cdr varlist)))) ! 766: (byte-compile-body (cdr (cdr form))) ! 767: (byte-compile-out 'byte-unbind (length (car (cdr form))))) ! 768: ! 769: (put 'save-excursion 'byte-compile 'byte-compile-save-excursion) ! 770: (defun byte-compile-save-excursion (form) ! 771: (byte-compile-out 'byte-save-excursion 0) ! 772: (byte-compile-body (cdr form)) ! 773: (byte-compile-out 'byte-unbind 1)) ! 774: ! 775: (put 'save-restriction 'byte-compile 'byte-compile-save-restriction) ! 776: (defun byte-compile-save-restriction (form) ! 777: (byte-compile-out 'byte-save-restriction 0) ! 778: (byte-compile-body (cdr form)) ! 779: (byte-compile-out 'byte-unbind 1)) ! 780: ! 781: (put 'with-output-to-temp-buffer 'byte-compile 'byte-compile-with-output-to-temp-buffer) ! 782: (defun byte-compile-with-output-to-temp-buffer (form) ! 783: (byte-compile-form (car (cdr form))) ! 784: (byte-compile-out 'byte-temp-output-buffer-setup 0) ! 785: (byte-compile-body (cdr (cdr form))) ! 786: (byte-compile-out 'byte-temp-output-buffer-show 0) ! 787: (setq byte-compile-depth (1- byte-compile-depth))) ! 788: ! 789: (put 'progn 'byte-compile 'byte-compile-progn) ! 790: (defun byte-compile-progn (form) ! 791: (byte-compile-body (cdr form))) ! 792: ! 793: (put 'interactive 'byte-compile 'byte-compile-noop) ! 794: (defun byte-compile-noop (form) ! 795: (byte-compile-constant nil)) ! 796: ! 797: (defun byte-compile-body (body) ! 798: (if (null body) ! 799: (byte-compile-constant nil) ! 800: (while body ! 801: (byte-compile-form (car body)) ! 802: (if (cdr body) ! 803: (byte-compile-discard) ! 804: ;; Convention is this will be counted after we return. ! 805: (setq byte-compile-depth (1- byte-compile-depth))) ! 806: (setq body (cdr body))))) ! 807: ! 808: (put 'prog1 'byte-compile 'byte-compile-prog1) ! 809: (defun byte-compile-prog1 (form) ! 810: (byte-compile-form (car (cdr form))) ! 811: (if (cdr (cdr form)) ! 812: (progn ! 813: (byte-compile-body (cdr (cdr form))) ! 814: ;; This discards the value pushed by ..-body ! 815: ;; (which is not counted now in byte-compile-depth) ! 816: ;; and decrements byte-compile-depth for the value ! 817: ;; pushed by byte-compile-form above, which by convention ! 818: ;; will be counted in byte-compile-depth after we return. ! 819: (byte-compile-discard)))) ! 820: ! 821: (put 'prog2 'byte-compile 'byte-compile-prog2) ! 822: (defun byte-compile-prog2 (form) ! 823: (byte-compile-form (car (cdr form))) ! 824: (byte-compile-discard) ! 825: (byte-compile-form (nth 2 form)) ! 826: (if (cdr (cdr (cdr form))) ! 827: (progn ! 828: (byte-compile-body (cdr (cdr (cdr form)))) ! 829: (byte-compile-discard)))) ! 830: ! 831: (defun byte-compile-discard () ! 832: (byte-compile-out 'byte-discard 0) ! 833: (setq byte-compile-depth (1- byte-compile-depth))) ! 834: ! 835: (put 'if 'byte-compile 'byte-compile-if) ! 836: (defun byte-compile-if (form) ! 837: (if (null (cdr (cdr form))) ! 838: ;; No else-forms ! 839: (let ((donetag (byte-compile-make-tag))) ! 840: (byte-compile-form (car (cdr form))) ! 841: (byte-compile-goto 'byte-goto-if-nil-else-pop donetag) ! 842: (setq byte-compile-depth (1- byte-compile-depth)) ! 843: (byte-compile-form (nth 2 form)) ! 844: (setq byte-compile-depth (1- byte-compile-depth)) ! 845: (byte-compile-out-tag donetag)) ! 846: (let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag))) ! 847: (byte-compile-form (car (cdr form))) ! 848: (byte-compile-goto 'byte-goto-if-nil elsetag) ! 849: (setq byte-compile-depth (1- byte-compile-depth)) ! 850: (byte-compile-form (nth 2 form)) ! 851: (setq byte-compile-depth (1- byte-compile-depth)) ! 852: (byte-compile-goto 'byte-goto donetag) ! 853: (byte-compile-out-tag elsetag) ! 854: (byte-compile-body (cdr (cdr (cdr form)))) ! 855: (byte-compile-out-tag donetag)))) ! 856: ! 857: (put 'cond 'byte-compile 'byte-compile-cond) ! 858: (defun byte-compile-cond (form) ! 859: (if (cdr form) ! 860: (byte-compile-cond-1 (cdr form)))) ! 861: (defun byte-compile-cond-1 (clauses) ! 862: (if (null (cdr clauses)) ! 863: ;; Only one clause ! 864: (let ((donetag (byte-compile-make-tag))) ! 865: (byte-compile-form (car (car clauses))) ! 866: (cond ((cdr (car clauses)) ! 867: (byte-compile-goto 'byte-goto-if-nil-else-pop donetag) ! 868: (setq byte-compile-depth (1- byte-compile-depth)) ! 869: (byte-compile-body (cdr (car clauses))) ! 870: (byte-compile-out-tag donetag)))) ! 871: (let ((donetag (byte-compile-make-tag)) ! 872: (elsetag (byte-compile-make-tag))) ! 873: (byte-compile-form (car (car clauses))) ! 874: (byte-compile-goto 'byte-goto-if-nil elsetag) ! 875: (setq byte-compile-depth (1- byte-compile-depth)) ! 876: (byte-compile-body (cdr (car clauses))) ! 877: (byte-compile-goto 'byte-goto donetag) ! 878: (byte-compile-out-tag elsetag) ! 879: (byte-compile-cond-1 (cdr clauses)) ! 880: (byte-compile-out-tag donetag)))) ! 881: ! 882: (put 'and 'byte-compile 'byte-compile-and) ! 883: (defun byte-compile-and (form) ! 884: (let ((failtag (byte-compile-make-tag)) ! 885: (args (cdr form))) ! 886: (if (null args) ! 887: (progn ! 888: (byte-compile-form t) ! 889: (setq byte-compile-depth (1- byte-compile-depth))) ! 890: (while args ! 891: (byte-compile-form (car args)) ! 892: (setq byte-compile-depth (1- byte-compile-depth)) ! 893: (if (null (cdr args)) ! 894: (byte-compile-out-tag failtag) ! 895: (byte-compile-goto 'byte-goto-if-nil-else-pop failtag)) ! 896: (setq args (cdr args)))))) ! 897: ! 898: (put 'or 'byte-compile 'byte-compile-or) ! 899: (defun byte-compile-or (form) ! 900: (let ((wintag (byte-compile-make-tag)) ! 901: (args (cdr form))) ! 902: (if (null args) ! 903: (byte-compile-constant nil) ! 904: (while args ! 905: (byte-compile-form (car args)) ! 906: (setq byte-compile-depth (1- byte-compile-depth)) ! 907: (if (null (cdr args)) ! 908: (byte-compile-out-tag wintag) ! 909: (byte-compile-goto 'byte-goto-if-not-nil-else-pop wintag)) ! 910: (setq args (cdr args)))))) ! 911: ! 912: (put 'while 'byte-compile 'byte-compile-while) ! 913: (defun byte-compile-while (form) ! 914: (let ((endtag (byte-compile-make-tag)) ! 915: (looptag (byte-compile-make-tag)) ! 916: (args (cdr (cdr form)))) ! 917: (byte-compile-out-tag looptag) ! 918: (byte-compile-form (car (cdr form))) ! 919: (byte-compile-goto 'byte-goto-if-nil-else-pop endtag) ! 920: (byte-compile-body (cdr (cdr form))) ! 921: (byte-compile-discard) ! 922: (byte-compile-goto 'byte-goto looptag) ! 923: (byte-compile-out-tag endtag))) ! 924: ! 925: (put 'catch 'byte-compile 'byte-compile-catch) ! 926: (defun byte-compile-catch (form) ! 927: (byte-compile-form (car (cdr form))) ! 928: (byte-compile-push-constant (byte-compile-top-level (cons 'progn (cdr (cdr form))))) ! 929: (setq byte-compile-depth (- byte-compile-depth 2)) ! 930: (byte-compile-out 'byte-catch 0)) ! 931: ! 932: (put 'save-window-excursion 'byte-compile 'byte-compile-save-window-excursion) ! 933: (defun byte-compile-save-window-excursion (form) ! 934: (byte-compile-push-constant ! 935: (list (byte-compile-top-level (cons 'progn (cdr form))))) ! 936: (setq byte-compile-depth (1- byte-compile-depth)) ! 937: (byte-compile-out 'byte-save-window-excursion 0)) ! 938: ! 939: (put 'unwind-protect 'byte-compile 'byte-compile-unwind-protect) ! 940: (defun byte-compile-unwind-protect (form) ! 941: (byte-compile-push-constant ! 942: (list (byte-compile-top-level (cons 'progn (cdr (cdr form)))))) ! 943: (setq byte-compile-depth (1- byte-compile-depth)) ! 944: (byte-compile-out 'byte-unwind-protect 0) ! 945: (byte-compile-form (car (cdr form))) ! 946: (setq byte-compile-depth (1- byte-compile-depth)) ! 947: (byte-compile-out 'byte-unbind 1)) ! 948: ! 949: (put 'condition-case 'byte-compile 'byte-compile-condition-case) ! 950: (defun byte-compile-condition-case (form) ! 951: (byte-compile-push-constant (car (cdr form))) ! 952: (byte-compile-push-constant (byte-compile-top-level (nth 2 form))) ! 953: (let ((clauses (cdr (cdr (cdr form)))) ! 954: compiled-clauses) ! 955: (while clauses ! 956: (let ((clause (car clauses))) ! 957: (setq compiled-clauses ! 958: (cons (list (car clause) ! 959: (byte-compile-top-level (cons 'progn (cdr clause)))) ! 960: compiled-clauses))) ! 961: (setq clauses (cdr clauses))) ! 962: (byte-compile-push-constant (nreverse compiled-clauses))) ! 963: (setq byte-compile-depth (- byte-compile-depth 3)) ! 964: (byte-compile-out 'byte-condition-case 0)) ! 965: ! 966: (defun byte-compile-make-tag () ! 967: (cons nil nil)) ! 968: ! 969: (defun byte-compile-out-tag (tag) ! 970: (let ((uses (car tag))) ! 971: (setcar tag byte-compile-pc) ! 972: (while uses ! 973: (byte-compile-store-goto (car uses) byte-compile-pc) ! 974: (setq uses (cdr uses))))) ! 975: ! 976: (defun byte-compile-goto (opcode tag) ! 977: (byte-compile-out opcode 0) ! 978: (if (integerp (car tag)) ! 979: (byte-compile-store-goto byte-compile-pc (car tag)) ! 980: (setcar tag (cons byte-compile-pc (car tag)))) ! 981: (setq byte-compile-pc (+ byte-compile-pc 2))) ! 982: ! 983: (defun byte-compile-store-goto (at-pc to-pc) ! 984: (setq byte-compile-output ! 985: (cons (cons at-pc (logand to-pc 255)) ! 986: byte-compile-output)) ! 987: (setq byte-compile-output ! 988: (cons (cons (1+ at-pc) (lsh to-pc -8)) ! 989: byte-compile-output))) ! 990: ! 991: (defun byte-compile-out (opcode offset) ! 992: (setq opcode (eval opcode)) ! 993: (if (< offset 6) ! 994: (byte-compile-out-1 (+ opcode offset)) ! 995: (if (< offset 256) ! 996: (progn ! 997: (byte-compile-out-1 (+ opcode 6)) ! 998: (byte-compile-out-1 offset)) ! 999: (byte-compile-out-1 (+ opcode 7)) ! 1000: (byte-compile-out-1 (logand offset 255)) ! 1001: (byte-compile-out-1 (lsh offset -8))))) ! 1002: ! 1003: (defun byte-compile-out-const (offset) ! 1004: (if (< offset byte-constant-limit) ! 1005: (byte-compile-out-1 (+ byte-constant offset)) ! 1006: (byte-compile-out-1 byte-constant2) ! 1007: (byte-compile-out-1 (logand offset 255)) ! 1008: (byte-compile-out-1 (lsh offset -8)))) ! 1009: ! 1010: (defun byte-compile-out-1 (code) ! 1011: (setq byte-compile-output ! 1012: (cons (cons byte-compile-pc code) ! 1013: byte-compile-output)) ! 1014: (setq byte-compile-pc (1+ byte-compile-pc))) ! 1015: ! 1016: ;;; by [email protected] ! 1017: ;;; Only works noninteractively. ! 1018: (defun batch-byte-compile () ! 1019: "Runs byte-compile-file on the files remaining on the command line. ! 1020: Must be used only with -batch, and kills emacs on completion. ! 1021: Each file will be processed even if an error occurred previously. ! 1022: For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\"" ! 1023: ;; command-line-args is what is left of the command line (from startup.el) ! 1024: (if (not noninteractive) ! 1025: (error "batch-byte-compile is to be used only with -batch")) ! 1026: (let ((error nil)) ! 1027: (while command-line-args ! 1028: (if (file-directory-p (expand-file-name (car command-line-args))) ! 1029: (let ((files (directory-files (car command-line-args))) ! 1030: source) ! 1031: (while files ! 1032: (if (and (string-match ".el$" (car files)) ! 1033: (not (auto-save-file-name-p (car files))) ! 1034: (setq source (expand-file-name (car files) ! 1035: (car command-line-args))) ! 1036: (file-exists-p (concat source "c")) ! 1037: (file-newer-than-file-p source (concat source "c"))) ! 1038: (if (null (batch-byte-compile-file source)) ! 1039: (setq error t))) ! 1040: (setq files (cdr files)))) ! 1041: (if (null (batch-byte-compile-file (car command-line-args))) ! 1042: (setq error t))) ! 1043: (setq command-line-args (cdr command-line-args))) ! 1044: (message "Done") ! 1045: (kill-emacs (if error 1 0)))) ! 1046: ! 1047: (defun batch-byte-compile-file (file) ! 1048: (condition-case err ! 1049: (progn (byte-compile-file file) t) ! 1050: (error ! 1051: (message (if (cdr err) ! 1052: ">>Error occurred processing %s: %s (%s)" ! 1053: ">>Error occurred processing %s: %s") ! 1054: file ! 1055: (get (car err) 'error-message) ! 1056: (prin1-to-string (cdr err))) ! 1057: nil)))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.