![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to bytecode.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / src|
Return to bytecode.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / src |
1.1 root 1: /* Execution of byte code produced by bytecomp.el.
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: #include "config.h"
23: #include "lisp.h"
24: #include "buffer.h"
25:
26: Lisp_Object Qbytecode;
27:
28: /* Byte codes: */
29:
30: #define Bvarref 010
31: #define Bvarset 020
32: #define Bvarbind 030
33: #define Bcall 040
34: #define Bunbind 050
35:
36: #define Bnth 070
37: #define Bsymbolp 071
38: #define Bconsp 072
39: #define Bstringp 073
40: #define Blistp 074
41: #define Beq 075
42: #define Bmemq 076
43: #define Bnot 077
44: #define Bcar 0100
45: #define Bcdr 0101
46: #define Bcons 0102
47: #define Blist1 0103
48: #define Blist2 0104
49: #define Blist3 0105
50: #define Blist4 0106
51: #define Blength 0107
52: #define Baref 0110
53: #define Baset 0111
54: #define Bsymbol_value 0112
55: #define Bsymbol_function 0113
56: #define Bset 0114
57: #define Bfset 0115
58: #define Bget 0116
59: #define Bsubstring 0117
60: #define Bconcat2 0120
61: #define Bconcat3 0121
62: #define Bconcat4 0122
63: #define Bsub1 0123
64: #define Badd1 0124
65: #define Beqlsign 0125
66: #define Bgtr 0126
67: #define Blss 0127
68: #define Bleq 0130
69: #define Bgeq 0131
70: #define Bdiff 0132
71: #define Bnegate 0133
72: #define Bplus 0134
73: #define Bmax 0135
74: #define Bmin 0136
75:
76: #define Bpoint 0140
77: #define Bmark 0141
78: #define Bgoto_char 0142
79: #define Binsert 0143
80: #define Bpoint_max 0144
81: #define Bpoint_min 0145
82: #define Bchar_after 0146
83: #define Bfollowing_char 0147
84: #define Bpreceding_char 0150
85: #define Bcurrent_column 0151
86: #define Bindent_to 0152
87: #define Bscan_buffer 0153
88: #define Beolp 0154
89: #define Beobp 0155
90: #define Bbolp 0156
91: #define Bbobp 0157
92: #define Bcurrent_buffer 0160
93: #define Bset_buffer 0161
94: #define Bread_char 0162
95: #define Bset_mark 0163
96: #define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */
97:
98: #define Bconstant2 0201
99: #define Bgoto 0202
100: #define Bgotoifnil 0203
101: #define Bgotoifnonnil 0204
102: #define Bgotoifnilelsepop 0205
103: #define Bgotoifnonnilelsepop 0206
104: #define Breturn 0207
105: #define Bdiscard 0210
106: #define Bdup 0211
107:
108: #define Bsave_excursion 0212
109: #define Bsave_window_excursion 0213
110: #define Bsave_restriction 0214
111: #define Bcatch 0215
112:
113: #define Bunwind_protect 0216
114: #define Bcondition_case 0217
115: #define Btemp_output_buffer_setup 0220
116: #define Btemp_output_buffer_show 0221
117:
118: #define Bconstant 0300
119: #define CONSTANTLIM 0100
120:
121: /* Fetch the next byte from the bytecode stream */
122:
123: #define FETCH ((unsigned char *)XSTRING (bytestr)->data)[pc++]
124:
125: /* Fetch two bytes from the bytecode stream
126: and make a 16-bit number out of them */
127:
128: #define FETCH2 (op = FETCH, op + (FETCH << 8))
129:
130: /* Push x onto the execution stack. */
131:
132: #define PUSH(x) (*++stackp = (x))
133:
134: /* Pop a value off the execution stack. */
135:
136: #define POP (*stackp--)
137:
138: /* Discard n values from the execution stack. */
139:
140: #define DISCARD(n) (stackp -= (n))
141:
142: /* Get the value which is at the top of the execution stack, but don't pop it. */
143:
144: #define TOP (*stackp)
145:
146:
147: DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
148: "")
149: (bytestr, vector, maxdepth)
150: Lisp_Object bytestr, vector, maxdepth;
151: {
152: struct gcpro gcpro1, gcpro2, gcpro3;
153: int count = specpdl_ptr - specpdl;
154: register int pc = 0;
155: register int op;
156: Lisp_Object *stack;
157: register Lisp_Object *stackp;
158: Lisp_Object *stacke;
159: register Lisp_Object v1, v2;
160: Lisp_Object *vectorp = XVECTOR (vector)->contents;
161:
162: CHECK_STRING (bytestr, 0);
163: if (XTYPE (vector) != Lisp_Vector)
164: vector = wrong_type_argument (Qvectorp, vector);
165: CHECK_NUMBER (maxdepth, 2);
166:
167: stackp = (Lisp_Object *) alloca (XFASTINT (maxdepth) * sizeof (Lisp_Object));
168: bzero (stackp, XFASTINT (maxdepth) * sizeof (Lisp_Object));
169: GCPRO3 (bytestr, vector, *stackp);
170: gcpro3.nvars = XFASTINT (maxdepth);
171:
172: --stackp;
173: stack = stackp;
174: stacke = stackp + XFASTINT (maxdepth);
175:
176: while (1)
177: {
178: if (stackp > stacke)
179: error ("Stack overflow in byte code (byte compiler bug!)");
180: if (stackp < stack)
181: error ("Stack underflow in byte code (byte compiler bug!)");
182: switch (op = FETCH)
183: {
184: case Bvarref: case Bvarref+1: case Bvarref+2: case Bvarref+3:
185: case Bvarref+4: case Bvarref+5:
186: PUSH (Fsymbol_value (vectorp[op - Bvarref]));
187: break;
188:
189: case Bvarref+6:
190: PUSH (Fsymbol_value (vectorp[FETCH]));
191: break;
192:
193: case Bvarref+7:
194: PUSH (Fsymbol_value (vectorp[FETCH2]));
195: break;
196:
197: case Bvarset: case Bvarset+1: case Bvarset+2: case Bvarset+3:
198: case Bvarset+4: case Bvarset+5:
199: Fset (vectorp[op - Bvarset], POP);
200: break;
201:
202: case Bvarset+6:
203: Fset (vectorp[FETCH], POP);
204: break;
205:
206: case Bvarset+7:
207: Fset (vectorp[FETCH2], POP);
208: break;
209:
210: case Bvarbind: case Bvarbind+1: case Bvarbind+2: case Bvarbind+3:
211: case Bvarbind+4: case Bvarbind+5:
212: specbind (vectorp[op - Bvarbind], POP);
213: break;
214:
215: case Bvarbind+6:
216: specbind (vectorp[FETCH], POP);
217: break;
218:
219: case Bvarbind+7:
220: specbind (vectorp[FETCH2], POP);
221: break;
222:
223: case Bcall: case Bcall+1: case Bcall+2: case Bcall+3:
224: case Bcall+4: case Bcall+5:
225: op -= Bcall;
226: docall:
227: DISCARD(op);
228: gcpro3.nvars = &TOP - stack;
229: TOP = Ffuncall (op + 1, &TOP);
230: gcpro3.nvars = XFASTINT (maxdepth);
231: break;
232:
233: case Bcall+6:
234: op = FETCH;
235: goto docall;
236:
237: case Bcall+7:
238: op = FETCH2;
239: goto docall;
240:
241: case Bunbind: case Bunbind+1: case Bunbind+2: case Bunbind+3:
242: case Bunbind+4: case Bunbind+5:
243: unbind_to (specpdl_ptr - specpdl - (op - Bunbind));
244: break;
245:
246: case Bunbind+6:
247: unbind_to (specpdl_ptr - specpdl - FETCH);
248: break;
249:
250: case Bunbind+7:
251: unbind_to (specpdl_ptr - specpdl - FETCH2);
252: break;
253:
254: case Bgoto:
255: QUIT;
256: op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
257: pc = op;
258: break;
259:
260: case Bgotoifnil:
261: QUIT;
262: op = FETCH2;
263: if (NULL (POP))
264: pc = op;
265: break;
266:
267: case Bgotoifnonnil:
268: QUIT;
269: op = FETCH2;
270: if (!NULL (POP))
271: pc = op;
272: break;
273:
274: case Bgotoifnilelsepop:
275: QUIT;
276: op = FETCH2;
277: if (NULL (TOP))
278: pc = op;
279: else DISCARD(1);
280: break;
281:
282: case Bgotoifnonnilelsepop:
283: QUIT;
284: op = FETCH2;
285: if (!NULL (TOP))
286: pc = op;
287: else DISCARD(1);
288: break;
289:
290: case Breturn:
291: v1 = POP;
292: goto exit;
293:
294: case Bdiscard:
295: DISCARD(1);
296: break;
297:
298: case Bdup:
299: v1 = TOP;
300: PUSH (v1);
301: break;
302:
303: case Bconstant2:
304: PUSH (vectorp[FETCH2]);
305: break;
306:
307: case Bsave_excursion:
308: record_unwind_protect (save_excursion_restore, save_excursion_save ());
309: break;
310:
311: case Bsave_window_excursion:
312: TOP = Fsave_window_excursion (TOP);
313: break;
314:
315: case Bsave_restriction:
316: record_unwind_protect (save_restriction_restore, save_restriction_save ());
317: break;
318:
319: case Bcatch:
320: v1 = POP;
321: TOP = internal_catch (TOP, Feval, v1);
322: break;
323:
324: case Bunwind_protect:
325: record_unwind_protect (0, POP);
326: (specpdl_ptr - 1)->symbol = Qnil;
327: break;
328:
329: case Bcondition_case:
330: v1 = POP;
331: v1 = Fcons (POP, v1);
332: TOP = Fcondition_case (Fcons (TOP, v1));
333: break;
334:
335: case Btemp_output_buffer_setup:
336: temp_output_buffer_setup (XSTRING (TOP)->data);
337: TOP = Vstandard_output;
338: break;
339:
340: case Btemp_output_buffer_show:
341: v1 = POP;
342: temp_output_buffer_show (TOP);
343: TOP = v1;
344: break;
345:
346: case Bnth:
347: v1 = POP;
348: v2 = TOP;
349: CHECK_NUMBER (v2, 0);
350: op = XINT (v2);
351: while (--op >= 0)
352: {
353: if (LISTP (v1))
354: v1 = XCONS (v1)->cdr;
355: else if (!NULL (v1))
356: {
357: v1 = wrong_type_argument (Qlistp, v1);
358: op++;
359: }
360: }
361: goto docar;
362:
363: case Bsymbolp:
364: TOP = XTYPE (TOP) == Lisp_Symbol ? Qt : Qnil;
365: break;
366:
367: case Bconsp:
368: TOP = LISTP (TOP) ? Qt : Qnil;
369: break;
370:
371: case Bstringp:
372: TOP = XTYPE (TOP) == Lisp_String ? Qt : Qnil;
373: break;
374:
375: case Blistp:
376: TOP = LISTP (TOP) || NULL (TOP) ? Qt : Qnil;
377: break;
378:
379: case Beq:
380: v1 = POP;
381: TOP = EQ (v1, TOP) ? Qt : Qnil;
382: break;
383:
384: case Bmemq:
385: v1 = POP;
386: TOP = Fmemq (TOP, v1);
387: break;
388:
389: case Bnot:
390: TOP = NULL (TOP) ? Qt : Qnil;
391: break;
392:
393: case Bcar:
394: v1 = TOP;
395: docar:
396: if (LISTP (v1)) TOP = XCONS (v1)->car;
397: else if (NULL (v1)) TOP = Qnil;
398: else Fcar (wrong_type_argument (Qlistp, v1));
399: break;
400:
401: case Bcdr:
402: v1 = TOP;
403: if (LISTP (v1)) TOP = XCONS (v1)->cdr;
404: else if (NULL (v1)) TOP = Qnil;
405: else Fcdr (wrong_type_argument (Qlistp, v1));
406: break;
407:
408: case Bcons:
409: v1 = POP;
410: TOP = Fcons (TOP, v1);
411: break;
412:
413: case Blist1:
414: TOP = Fcons (TOP, Qnil);
415: break;
416:
417: case Blist2:
418: v1 = POP;
419: TOP = Fcons (TOP, Fcons (v1, Qnil));
420: break;
421:
422: case Blist3:
423: DISCARD(2);
424: TOP = Flist (3, &TOP);
425: break;
426:
427: case Blist4:
428: DISCARD(3);
429: TOP = Flist (4, &TOP);
430: break;
431:
432: case Blength:
433: TOP = Flength (TOP);
434: break;
435:
436: case Baref:
437: v1 = POP;
438: TOP = Faref (TOP, v1);
439: break;
440:
441: case Baset:
442: v2 = POP; v1 = POP;
443: TOP = Faset (TOP, v1, v2);
444: break;
445:
446: case Bsymbol_value:
447: TOP = Fsymbol_value (TOP);
448: break;
449:
450: case Bsymbol_function:
451: TOP = Fsymbol_function (TOP);
452: break;
453:
454: case Bset:
455: v1 = POP;
456: TOP = Fset (TOP, v1);
457: break;
458:
459: case Bfset:
460: v1 = POP;
461: TOP = Ffset (TOP, v1);
462: break;
463:
464: case Bget:
465: v1 = POP;
466: TOP = Fget (TOP, v1);
467: break;
468:
469: case Bsubstring:
470: v2 = POP; v1 = POP;
471: TOP = Fsubstring (TOP, v1, v2);
472: break;
473:
474: case Bconcat2:
475: DISCARD(1);
476: TOP = Fconcat (2, &TOP);
477: break;
478:
479: case Bconcat3:
480: DISCARD(2);
481: TOP = Fconcat (3, &TOP);
482: break;
483:
484: case Bconcat4:
485: DISCARD(3);
486: TOP = Fconcat (4, &TOP);
487: break;
488:
489: case Bsub1:
490: v1 = TOP;
491: if (XTYPE (v1) == Lisp_Int)
492: {
493: XSETINT (v1, XINT (v1) - 1);
494: TOP = v1;
495: }
496: else
497: TOP = Fsub1 (v1);
498: break;
499:
500: case Badd1:
501: v1 = TOP;
502: if (XTYPE (v1) == Lisp_Int)
503: {
504: XSETINT (v1, XINT (v1) + 1);
505: TOP = v1;
506: }
507: else
508: TOP = Fadd1 (v1);
509: break;
510:
511: case Beqlsign:
512: v2 = POP; v1 = TOP;
513: CHECK_NUMBER_COERCE_MARKER (v1, 0);
514: CHECK_NUMBER_COERCE_MARKER (v2, 0);
515: TOP = XINT (v1) == XINT (v2) ? Qt : Qnil;
516: break;
517:
518: case Bgtr:
519: v1 = POP;
520: TOP = Fgtr (TOP, v1);
521: break;
522:
523: case Blss:
524: v1 = POP;
525: TOP = Flss (TOP, v1);
526: break;
527:
528: case Bleq:
529: v1 = POP;
530: TOP = Fleq (TOP, v1);
531: break;
532:
533: case Bgeq:
534: v1 = POP;
535: TOP = Fgeq (TOP, v1);
536: break;
537:
538: case Bdiff:
539: DISCARD(1);
540: TOP = Fminus (2, &TOP);
541: break;
542:
543: case Bnegate:
544: v1 = TOP;
545: if (XTYPE (v1) == Lisp_Int)
546: {
547: XSETINT (v1, - XINT (v1));
548: TOP = v1;
549: }
550: else
551: TOP = Fminus (1, &TOP);
552: break;
553:
554: case Bplus:
555: DISCARD(1);
556: TOP = Fplus (2, &TOP);
557: break;
558:
559: case Bmax:
560: DISCARD(1);
561: TOP = Fmax (2, &TOP);
562: break;
563:
564: case Bmin:
565: DISCARD(1);
566: TOP = Fmin (2, &TOP);
567: break;
568:
569: case Bpoint:
570: XFASTINT (v1) = point;
571: PUSH (v1);
572: break;
573:
574: case Bmark:
575: PUSH (Fmark ());
576: break;
577:
578: case Bgoto_char:
579: TOP = Fgoto_char (TOP);
580: break;
581:
582: case Binsert:
583: TOP = Finsert (1, &TOP);
584: break;
585:
586: case Bpoint_max:
587: XFASTINT (v1) = NumCharacters+1;
588: PUSH (v1);
589: break;
590:
591: case Bpoint_min:
592: XFASTINT (v1) = FirstCharacter;
593: PUSH (v1);
594: break;
595:
596: case Bchar_after:
597: TOP = Fchar_after (TOP);
598: break;
599:
600: case Bfollowing_char:
601: XFASTINT (v1) = point>NumCharacters ? 0 : CharAt(point);
602: PUSH (v1);
603: break;
604:
605: case Bpreceding_char:
606: XFASTINT (v1) = point<=FirstCharacter ? 0 : CharAt(point-1);
607: PUSH (v1);
608: break;
609:
610: case Bcurrent_column:
611: XFASTINT (v1) = current_column ();
612: PUSH (v1);
613: break;
614:
615: case Bindent_to:
616: TOP = Findent_to (TOP, Qnil);
617: break;
618:
619: case Bscan_buffer:
620: v2 = POP; v1 = POP;
621: TOP = Fscan_buffer (TOP, v1, v2);
622: break;
623:
624: case Beolp:
625: PUSH (Feolp ());
626: break;
627:
628: case Beobp:
629: PUSH (Feobp ());
630: break;
631:
632: case Bbolp:
633: PUSH (Fbolp ());
634: break;
635:
636: case Bbobp:
637: PUSH (Fbobp ());
638: break;
639:
640: case Bcurrent_buffer:
641: PUSH (Fcurrent_buffer ());
642: break;
643:
644: case Bset_buffer:
645: TOP = Fset_buffer (TOP);
646: break;
647:
648: case Bread_char:
649: PUSH (Fread_char ());
650: QUIT;
651: break;
652:
653: case Bset_mark:
654: TOP = Fset_mark (TOP);
655: break;
656:
657: case Binteractive_p:
658: PUSH (Finteractive_p ());
659: break;
660:
661: default:
662: if ((op -= Bconstant) < (unsigned)CONSTANTLIM)
663: PUSH (vectorp[op]);
664: }
665: }
666:
667: exit:
668: UNGCPRO;
669: unbind_to (count);
670: return v1;
671: }
672:
673: syms_of_bytecode ()
674: {
675: Qbytecode = intern ("byte-code");
676: staticpro (&Qbytecode);
677:
678: defsubr (&Sbyte_code);
679: }
680:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.