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