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