![[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.