![[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] / 43BSDReno / contrib / emacs-18.55 / src|
Return to bytecode.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / src |
1.1 root 1: /* Execution of byte code produced by bytecomp.el.
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:
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 /* no longer generated as of v18 */
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 /* No longer generated as of v18 */
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 /* this loser is no longer generated as of v18 */
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: register 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), pc = %d", pc);
180: if (stackp < stack)
181: error ("Stack underflow in byte code (byte compiler bug), pc = %d", pc);
182: switch (op = FETCH)
183: {
184: case Bvarref+6:
185: op = FETCH;
186: goto varref;
187:
188: case Bvarref+7:
189: op = FETCH2;
190: goto varref;
191:
192: case Bvarref: case Bvarref+1: case Bvarref+2: case Bvarref+3:
193: case Bvarref+4: case Bvarref+5:
194: op = op - Bvarref;
195: varref:
196: v1 = vectorp[op];
197: if (XTYPE (v1) != Lisp_Symbol)
198: v2 = Fsymbol_value (v1);
199: else
200: {
201: v2 = XSYMBOL (v1)->value;
202: #ifdef SWITCH_ENUM_BUG
203: switch ((int) XTYPE (v2))
204: #else
205: switch (XTYPE (v2))
206: #endif
207: {
208: case Lisp_Symbol:
209: if (!EQ (v2, Qunbound))
210: break;
211: case Lisp_Intfwd:
212: case Lisp_Boolfwd:
213: case Lisp_Objfwd:
214: case Lisp_Buffer_Local_Value:
215: case Lisp_Some_Buffer_Local_Value:
216: case Lisp_Buffer_Objfwd:
217: case Lisp_Void:
218: v2 = Fsymbol_value (v1);
219: }
220: }
221: PUSH (v2);
222: break;
223:
224: case Bvarset+6:
225: op = FETCH;
226: goto varset;
227:
228: case Bvarset+7:
229: op = FETCH2;
230: goto varset;
231:
232: case Bvarset: case Bvarset+1: case Bvarset+2: case Bvarset+3:
233: case Bvarset+4: case Bvarset+5:
234: op -= Bvarset;
235: varset:
236: Fset (vectorp[op], POP);
237: break;
238:
239: case Bvarbind+6:
240: op = FETCH;
241: goto varbind;
242:
243: case Bvarbind+7:
244: op = FETCH2;
245: goto varbind;
246:
247: case Bvarbind: case Bvarbind+1: case Bvarbind+2: case Bvarbind+3:
248: case Bvarbind+4: case Bvarbind+5:
249: op -= Bvarbind;
250: varbind:
251: specbind (vectorp[op], POP);
252: break;
253:
254: case Bcall+6:
255: op = FETCH;
256: goto docall;
257:
258: case Bcall+7:
259: op = FETCH2;
260: goto docall;
261:
262: case Bcall: case Bcall+1: case Bcall+2: case Bcall+3:
263: case Bcall+4: case Bcall+5:
264: op -= Bcall;
265: docall:
266: DISCARD(op);
267: /* Remove protection from the args we are giving to Ffuncall.
268: FFuncall will protect them, and double protection would
269: cause disasters. */
270: gcpro3.nvars = &TOP - stack - 1;
271: TOP = Ffuncall (op + 1, &TOP);
272: gcpro3.nvars = XFASTINT (maxdepth);
273: break;
274:
275: case Bunbind+6:
276: op = FETCH;
277: goto dounbind;
278:
279: case Bunbind+7:
280: op = FETCH2;
281: goto dounbind;
282:
283: case Bunbind: case Bunbind+1: case Bunbind+2: case Bunbind+3:
284: case Bunbind+4: case Bunbind+5:
285: op -= Bunbind;
286: dounbind:
287: unbind_to (specpdl_ptr - specpdl - op);
288: break;
289:
290: case Bgoto:
291: QUIT;
292: op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
293: pc = op;
294: break;
295:
296: case Bgotoifnil:
297: QUIT;
298: op = FETCH2;
299: if (NULL (POP))
300: pc = op;
301: break;
302:
303: case Bgotoifnonnil:
304: QUIT;
305: op = FETCH2;
306: if (!NULL (POP))
307: pc = op;
308: break;
309:
310: case Bgotoifnilelsepop:
311: QUIT;
312: op = FETCH2;
313: if (NULL (TOP))
314: pc = op;
315: else DISCARD(1);
316: break;
317:
318: case Bgotoifnonnilelsepop:
319: QUIT;
320: op = FETCH2;
321: if (!NULL (TOP))
322: pc = op;
323: else DISCARD(1);
324: break;
325:
326: case Breturn:
327: v1 = POP;
328: goto exit;
329:
330: case Bdiscard:
331: DISCARD(1);
332: break;
333:
334: case Bdup:
335: v1 = TOP;
336: PUSH (v1);
337: break;
338:
339: case Bconstant2:
340: PUSH (vectorp[FETCH2]);
341: break;
342:
343: case Bsave_excursion:
344: record_unwind_protect (save_excursion_restore, save_excursion_save ());
345: break;
346:
347: case Bsave_window_excursion:
348: TOP = Fsave_window_excursion (TOP);
349: break;
350:
351: case Bsave_restriction:
352: record_unwind_protect (save_restriction_restore, save_restriction_save ());
353: break;
354:
355: case Bcatch:
356: v1 = POP;
357: TOP = internal_catch (TOP, Feval, v1);
358: break;
359:
360: case Bunwind_protect:
361: record_unwind_protect (0, POP);
362: (specpdl_ptr - 1)->symbol = Qnil;
363: break;
364:
365: case Bcondition_case:
366: v1 = POP;
367: v1 = Fcons (POP, v1);
368: TOP = Fcondition_case (Fcons (TOP, v1));
369: break;
370:
371: case Btemp_output_buffer_setup:
372: temp_output_buffer_setup (XSTRING (TOP)->data);
373: TOP = Vstandard_output;
374: break;
375:
376: case Btemp_output_buffer_show:
377: v1 = POP;
378: temp_output_buffer_show (TOP);
379: TOP = v1;
380: /* pop binding of standard-output */
381: unbind_to (specpdl_ptr - specpdl - 1);
382: break;
383:
384: case Bnth:
385: v1 = POP;
386: v2 = TOP;
387: CHECK_NUMBER (v2, 0);
388: op = XINT (v2);
389: immediate_quit = 1;
390: while (--op >= 0)
391: {
392: if (CONSP (v1))
393: v1 = XCONS (v1)->cdr;
394: else if (!NULL (v1))
395: {
396: immediate_quit = 0;
397: v1 = wrong_type_argument (Qlistp, v1);
398: immediate_quit = 1;
399: op++;
400: }
401: }
402: immediate_quit = 0;
403: goto docar;
404:
405: case Bsymbolp:
406: TOP = XTYPE (TOP) == Lisp_Symbol ? Qt : Qnil;
407: break;
408:
409: case Bconsp:
410: TOP = CONSP (TOP) ? Qt : Qnil;
411: break;
412:
413: case Bstringp:
414: TOP = XTYPE (TOP) == Lisp_String ? Qt : Qnil;
415: break;
416:
417: case Blistp:
418: TOP = CONSP (TOP) || NULL (TOP) ? Qt : Qnil;
419: break;
420:
421: case Beq:
422: v1 = POP;
423: TOP = EQ (v1, TOP) ? Qt : Qnil;
424: break;
425:
426: case Bmemq:
427: v1 = POP;
428: TOP = Fmemq (TOP, v1);
429: break;
430:
431: case Bnot:
432: TOP = NULL (TOP) ? Qt : Qnil;
433: break;
434:
435: case Bcar:
436: v1 = TOP;
437: docar:
438: if (CONSP (v1)) TOP = XCONS (v1)->car;
439: else if (NULL (v1)) TOP = Qnil;
440: else Fcar (wrong_type_argument (Qlistp, v1));
441: break;
442:
443: case Bcdr:
444: v1 = TOP;
445: if (CONSP (v1)) TOP = XCONS (v1)->cdr;
446: else if (NULL (v1)) TOP = Qnil;
447: else Fcdr (wrong_type_argument (Qlistp, v1));
448: break;
449:
450: case Bcons:
451: v1 = POP;
452: TOP = Fcons (TOP, v1);
453: break;
454:
455: case Blist1:
456: TOP = Fcons (TOP, Qnil);
457: break;
458:
459: case Blist2:
460: v1 = POP;
461: TOP = Fcons (TOP, Fcons (v1, Qnil));
462: break;
463:
464: case Blist3:
465: DISCARD(2);
466: TOP = Flist (3, &TOP);
467: break;
468:
469: case Blist4:
470: DISCARD(3);
471: TOP = Flist (4, &TOP);
472: break;
473:
474: case Blength:
475: TOP = Flength (TOP);
476: break;
477:
478: case Baref:
479: v1 = POP;
480: TOP = Faref (TOP, v1);
481: break;
482:
483: case Baset:
484: v2 = POP; v1 = POP;
485: TOP = Faset (TOP, v1, v2);
486: break;
487:
488: case Bsymbol_value:
489: TOP = Fsymbol_value (TOP);
490: break;
491:
492: case Bsymbol_function:
493: TOP = Fsymbol_function (TOP);
494: break;
495:
496: case Bset:
497: v1 = POP;
498: TOP = Fset (TOP, v1);
499: break;
500:
501: case Bfset:
502: v1 = POP;
503: TOP = Ffset (TOP, v1);
504: break;
505:
506: case Bget:
507: v1 = POP;
508: TOP = Fget (TOP, v1);
509: break;
510:
511: case Bsubstring:
512: v2 = POP; v1 = POP;
513: TOP = Fsubstring (TOP, v1, v2);
514: break;
515:
516: case Bconcat2:
517: DISCARD(1);
518: TOP = Fconcat (2, &TOP);
519: break;
520:
521: case Bconcat3:
522: DISCARD(2);
523: TOP = Fconcat (3, &TOP);
524: break;
525:
526: case Bconcat4:
527: DISCARD(3);
528: TOP = Fconcat (4, &TOP);
529: break;
530:
531: case Bsub1:
532: v1 = TOP;
533: if (XTYPE (v1) == Lisp_Int)
534: {
535: XSETINT (v1, XINT (v1) - 1);
536: TOP = v1;
537: }
538: else
539: TOP = Fsub1 (v1);
540: break;
541:
542: case Badd1:
543: v1 = TOP;
544: if (XTYPE (v1) == Lisp_Int)
545: {
546: XSETINT (v1, XINT (v1) + 1);
547: TOP = v1;
548: }
549: else
550: TOP = Fadd1 (v1);
551: break;
552:
553: case Beqlsign:
554: v2 = POP; v1 = TOP;
555: CHECK_NUMBER_COERCE_MARKER (v1, 0);
556: CHECK_NUMBER_COERCE_MARKER (v2, 0);
557: TOP = XINT (v1) == XINT (v2) ? Qt : Qnil;
558: break;
559:
560: case Bgtr:
561: v1 = POP;
562: TOP = Fgtr (TOP, v1);
563: break;
564:
565: case Blss:
566: v1 = POP;
567: TOP = Flss (TOP, v1);
568: break;
569:
570: case Bleq:
571: v1 = POP;
572: TOP = Fleq (TOP, v1);
573: break;
574:
575: case Bgeq:
576: v1 = POP;
577: TOP = Fgeq (TOP, v1);
578: break;
579:
580: case Bdiff:
581: DISCARD(1);
582: TOP = Fminus (2, &TOP);
583: break;
584:
585: case Bnegate:
586: v1 = TOP;
587: if (XTYPE (v1) == Lisp_Int)
588: {
589: XSETINT (v1, - XINT (v1));
590: TOP = v1;
591: }
592: else
593: TOP = Fminus (1, &TOP);
594: break;
595:
596: case Bplus:
597: DISCARD(1);
598: TOP = Fplus (2, &TOP);
599: break;
600:
601: case Bmax:
602: DISCARD(1);
603: TOP = Fmax (2, &TOP);
604: break;
605:
606: case Bmin:
607: DISCARD(1);
608: TOP = Fmin (2, &TOP);
609: break;
610:
611: case Bpoint:
612: XFASTINT (v1) = point;
613: PUSH (v1);
614: break;
615:
616: case Bmark: /* this loser is no longer generated as of v18 */
617: PUSH (Fmarker_position (bf_cur->mark));
618: break;
619:
620: case Bgoto_char:
621: TOP = Fgoto_char (TOP);
622: break;
623:
624: case Binsert:
625: TOP = Finsert (1, &TOP);
626: break;
627:
628: case Bpoint_max:
629: XFASTINT (v1) = NumCharacters+1;
630: PUSH (v1);
631: break;
632:
633: case Bpoint_min:
634: XFASTINT (v1) = FirstCharacter;
635: PUSH (v1);
636: break;
637:
638: case Bchar_after:
639: TOP = Fchar_after (TOP);
640: break;
641:
642: case Bfollowing_char:
643: XFASTINT (v1) = point>NumCharacters ? 0 : CharAt(point);
644: PUSH (v1);
645: break;
646:
647: case Bpreceding_char:
648: XFASTINT (v1) = point<=FirstCharacter ? 0 : CharAt(point-1);
649: PUSH (v1);
650: break;
651:
652: case Bcurrent_column:
653: XFASTINT (v1) = current_column ();
654: PUSH (v1);
655: break;
656:
657: case Bindent_to:
658: TOP = Findent_to (TOP, Qnil);
659: break;
660:
661: case Bscan_buffer:
662: /* Get an appropriate error. */
663: Fsymbol_function (intern ("scan-buffer"));
664: break;
665:
666: case Beolp:
667: PUSH (Feolp ());
668: break;
669:
670: case Beobp:
671: PUSH (Feobp ());
672: break;
673:
674: case Bbolp:
675: PUSH (Fbolp ());
676: break;
677:
678: case Bbobp:
679: PUSH (Fbobp ());
680: break;
681:
682: case Bcurrent_buffer:
683: PUSH (Fcurrent_buffer ());
684: break;
685:
686: case Bset_buffer:
687: TOP = Fset_buffer (TOP);
688: break;
689:
690: case Bread_char:
691: PUSH (Fread_char ());
692: QUIT;
693: break;
694:
695: case Bset_mark: /* this loser is no longer generated as of v18 */
696: /* TOP = Fset_mark (TOP); */
697: TOP = Fset_marker (bf_cur->mark, TOP, Fcurrent_buffer ());
698: break;
699:
700: case Binteractive_p:
701: PUSH (Finteractive_p ());
702: break;
703:
704: default:
705: if ((op -= Bconstant) < (unsigned)CONSTANTLIM)
706: PUSH (vectorp[op]);
707: }
708: }
709:
710: exit:
711: UNGCPRO;
712: /* Binds and unbinds are supposed to be compiled balanced. */
713: if (specpdl_ptr - specpdl != count)
714: abort ();
715: return v1;
716: }
717:
718: syms_of_bytecode ()
719: {
720: Qbytecode = intern ("byte-code");
721: staticpro (&Qbytecode);
722:
723: defsubr (&Sbyte_code);
724: }
725:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.