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