]> code.delx.au - gnu-emacs/blob - src/bytecode.c
delx.au / code / gnu-emacs / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
*** empty log message ***
[gnu-emacs] / src / bytecode.c
1 /* Execution of byte code produced by bytecomp.el.
2 Copyright (C) 1985, 1986, 1987, 1988 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 hacked on by jwz@lucid.com 17-jun-91
21 o added a compile-time switch to turn on simple sanity checking;
22 o put back the obsolete byte-codes for error-detection;
23 o added a new instruction, unbind_all, which I will use for
24 tail-recursion elimination;
25 o made temp_output_buffer_show be called with the right number
26 of args;
27 o made the new bytecodes be called with args in the right order;
28 o added metering support.
29
30 by Hallvard:
31 o added relative jump instructions;
32 o all conditionals now only do QUIT if they jump.
33 */
34
35 #include "config.h"
36 #include "lisp.h"
37 #include "buffer.h"
38 #include "syntax.h"
39
40 /*
41 * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for
42 * debugging the byte compiler...)
43 *
44 * define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
45 */
46 /* #define BYTE_CODE_SAFE */
47 /* #define BYTE_CODE_METER */
48
49 \f
50 #ifdef BYTE_CODE_METER
51
52 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
53 int byte_metering_on;
54
55 #define METER_2(code1, code2) \
56 XFASTINT (XVECTOR (XVECTOR (Vbyte_code_meter)->contents[(code1)]) \
57 ->contents[(code2)])
58
59 #define METER_1(code) METER_2 (0, (code))
60
61 #define METER_CODE(last_code, this_code) \
62 { \
63 if (byte_metering_on) \
64 { \
65 if (METER_1 (this_code) != ((1<<VALBITS)-1)) \
66 METER_1 (this_code)++; \
67 if (last_code \
68 && METER_2 (last_code, this_code) != ((1<<VALBITS)-1)) \
69 METER_2 (last_code, this_code)++; \
70 } \
71 }
72
73 #else /* no BYTE_CODE_METER */
74
75 #define METER_CODE(last_code, this_code)
76
77 #endif /* no BYTE_CODE_METER */
78 \f
79
80 Lisp_Object Qbytecode;
81
82 /* Byte codes: */
83
84 #define Bvarref 010
85 #define Bvarset 020
86 #define Bvarbind 030
87 #define Bcall 040
88 #define Bunbind 050
89
90 #define Bnth 070
91 #define Bsymbolp 071
92 #define Bconsp 072
93 #define Bstringp 073
94 #define Blistp 074
95 #define Beq 075
96 #define Bmemq 076
97 #define Bnot 077
98 #define Bcar 0100
99 #define Bcdr 0101
100 #define Bcons 0102
101 #define Blist1 0103
102 #define Blist2 0104
103 #define Blist3 0105
104 #define Blist4 0106
105 #define Blength 0107
106 #define Baref 0110
107 #define Baset 0111
108 #define Bsymbol_value 0112
109 #define Bsymbol_function 0113 /* no longer generated as of v19 */
110 #define Bset 0114
111 #define Bfset 0115 /* no longer generated as of v19 */
112 #define Bget 0116
113 #define Bsubstring 0117
114 #define Bconcat2 0120
115 #define Bconcat3 0121
116 #define Bconcat4 0122
117 #define Bsub1 0123
118 #define Badd1 0124
119 #define Beqlsign 0125
120 #define Bgtr 0126
121 #define Blss 0127
122 #define Bleq 0130
123 #define Bgeq 0131
124 #define Bdiff 0132
125 #define Bnegate 0133
126 #define Bplus 0134
127 #define Bmax 0135
128 #define Bmin 0136
129 #define Bmult 0137
130
131 #define Bpoint 0140
132 #define Bmark 0141 /* no longer generated as of v18 */
133 #define Bgoto_char 0142
134 #define Binsert 0143
135 #define Bpoint_max 0144
136 #define Bpoint_min 0145
137 #define Bchar_after 0146
138 #define Bfollowing_char 0147
139 #define Bpreceding_char 0150
140 #define Bcurrent_column 0151
141 #define Bindent_to 0152
142 #define Bscan_buffer 0153 /* No longer generated as of v18 */
143 #define Beolp 0154
144 #define Beobp 0155
145 #define Bbolp 0156
146 #define Bbobp 0157
147 #define Bcurrent_buffer 0160
148 #define Bset_buffer 0161
149 #define Bread_char 0162 /* No longer generated as of v19 */
150 #define Bset_mark 0163 /* this loser is no longer generated as of v18 */
151 #define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */
152
153 #define Bforward_char 0165
154 #define Bforward_word 0166
155 #define Bskip_chars_forward 0167
156 #define Bskip_chars_backward 0170
157 #define Bforward_line 0171
158 #define Bchar_syntax 0172
159 #define Bbuffer_substring 0173
160 #define Bdelete_region 0174
161 #define Bnarrow_to_region 0175
162 #define Bwiden 0176
163 #define Bend_of_line 0177
164
165 #define Bconstant2 0201
166 #define Bgoto 0202
167 #define Bgotoifnil 0203
168 #define Bgotoifnonnil 0204
169 #define Bgotoifnilelsepop 0205
170 #define Bgotoifnonnilelsepop 0206
171 #define Breturn 0207
172 #define Bdiscard 0210
173 #define Bdup 0211
174
175 #define Bsave_excursion 0212
176 #define Bsave_window_excursion 0213
177 #define Bsave_restriction 0214
178 #define Bcatch 0215
179
180 #define Bunwind_protect 0216
181 #define Bcondition_case 0217
182 #define Btemp_output_buffer_setup 0220
183 #define Btemp_output_buffer_show 0221
184
185 #define Bunbind_all 0222
186
187 #define Bset_marker 0223
188 #define Bmatch_beginning 0224
189 #define Bmatch_end 0225
190 #define Bupcase 0226
191 #define Bdowncase 0227
192
193 #define Bstringeqlsign 0230
194 #define Bstringlss 0231
195 #define Bequal 0232
196 #define Bnthcdr 0233
197 #define Belt 0234
198 #define Bmember 0235
199 #define Bassq 0236
200 #define Bnreverse 0237
201 #define Bsetcar 0240
202 #define Bsetcdr 0241
203 #define Bcar_safe 0242
204 #define Bcdr_safe 0243
205 #define Bnconc 0244
206 #define Bquo 0245
207 #define Brem 0246
208 #define Bnumberp 0247
209 #define Bintegerp 0250
210
211 #define BRgoto 0252
212 #define BRgotoifnil 0253
213 #define BRgotoifnonnil 0254
214 #define BRgotoifnilelsepop 0255
215 #define BRgotoifnonnilelsepop 0256
216
217 #define BlistN 0257
218 #define BconcatN 0260
219 #define BinsertN 0261
220
221 #define Bconstant 0300
222 #define CONSTANTLIM 0100
223 \f
224 /* Fetch the next byte from the bytecode stream */
225
226 #define FETCH *pc++
227
228 /* Fetch two bytes from the bytecode stream
229 and make a 16-bit number out of them */
230
231 #define FETCH2 (op = FETCH, op + (FETCH << 8))
232
233 /* Push x onto the execution stack. */
234
235 /* This used to be #define PUSH(x) (*++stackp = (x))
236 This oddity is necessary because Alliant can't be bothered to
237 compile the preincrement operator properly, as of 4/91. -JimB */
238 #define PUSH(x) (stackp++, *stackp = (x))
239
240 /* Pop a value off the execution stack. */
241
242 #define POP (*stackp--)
243
244 /* Discard n values from the execution stack. */
245
246 #define DISCARD(n) (stackp -= (n))
247
248 /* Get the value which is at the top of the execution stack, but don't pop it. */
249
250 #define TOP (*stackp)
251
252 DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
253 "Function used internally in byte-compiled code.\n\
254 The first argument is a string of byte code; the second, a vector of constants;\n\
255 the third, the maximum stack depth used in this function.\n\
256 If the third argument is incorrect, Emacs may crash.")
257 (bytestr, vector, maxdepth)
258 Lisp_Object bytestr, vector, maxdepth;
259 {
260 struct gcpro gcpro1, gcpro2, gcpro3;
261 int count = specpdl_ptr - specpdl;
262 #ifdef BYTE_CODE_METER
263 int this_op = 0;
264 int prev_op;
265 #endif
266 register int op;
267 unsigned char *pc;
268 Lisp_Object *stack;
269 register Lisp_Object *stackp;
270 Lisp_Object *stacke;
271 register Lisp_Object v1, v2;
272 register Lisp_Object *vectorp = XVECTOR (vector)->contents;
273 #ifdef BYTE_CODE_SAFE
274 register int const_length = XVECTOR (vector)->size;
275 #endif
276 /* Copy of BYTESTR, saved so we can tell if BYTESTR was relocated. */
277 Lisp_Object string_saved;
278 /* Cached address of beginning of string,
279 valid if BYTESTR equals STRING_SAVED. */
280 register unsigned char *strbeg;
281
282 CHECK_STRING (bytestr, 0);
283 if (XTYPE (vector) != Lisp_Vector)
284 vector = wrong_type_argument (Qvectorp, vector);
285 CHECK_NUMBER (maxdepth, 2);
286
287 stackp = (Lisp_Object *) alloca (XFASTINT (maxdepth) * sizeof (Lisp_Object));
288 bzero (stackp, XFASTINT (maxdepth) * sizeof (Lisp_Object));
289 GCPRO3 (bytestr, vector, *stackp);
290 gcpro3.nvars = XFASTINT (maxdepth);
291
292 --stackp;
293 stack = stackp;
294 stacke = stackp + XFASTINT (maxdepth);
295
296 /* Initialize the saved pc-pointer for fetching from the string. */
297 string_saved = bytestr;
298 pc = XSTRING (string_saved)->data;
299
300 while (1)
301 {
302 #ifdef BYTE_CODE_SAFE
303 if (stackp > stacke)
304 error ("Byte code stack overflow (byte compiler bug), pc %d, depth %d",
305 pc - XSTRING (string_saved)->data, stacke - stackp);
306 if (stackp < stack)
307 error ("Byte code stack underflow (byte compiler bug), pc %d",
308 pc - XSTRING (string_saved)->data);
309 #endif
310
311 if (string_saved != bytestr)
312 {
313 pc = pc - XSTRING (string_saved)->data + XSTRING (bytestr)->data;
314 string_saved = bytestr;
315 }
316
317 #ifdef BYTE_CODE_METER
318 prev_op = this_op;
319 this_op = op = FETCH;
320 METER_CODE (prev_op, op);
321 switch (op)
322 #else
323 switch (op = FETCH)
324 #endif
325 {
326 case Bvarref+6:
327 op = FETCH;
328 goto varref;
329
330 case Bvarref+7:
331 op = FETCH2;
332 goto varref;
333
334 case Bvarref: case Bvarref+1: case Bvarref+2: case Bvarref+3:
335 case Bvarref+4: case Bvarref+5:
336 op = op - Bvarref;
337 varref:
338 v1 = vectorp[op];
339 if (XTYPE (v1) != Lisp_Symbol)
340 v2 = Fsymbol_value (v1);
341 else
342 {
343 v2 = XSYMBOL (v1)->value;
344 #ifdef SWITCH_ENUM_BUG
345 switch ((int) XTYPE (v2))
346 #else
347 switch (XTYPE (v2))
348 #endif
349 {
350 case Lisp_Symbol:
351 if (!EQ (v2, Qunbound))
352 break;
353 case Lisp_Intfwd:
354 case Lisp_Boolfwd:
355 case Lisp_Objfwd:
356 case Lisp_Buffer_Local_Value:
357 case Lisp_Some_Buffer_Local_Value:
358 case Lisp_Buffer_Objfwd:
359 case Lisp_Void:
360 v2 = Fsymbol_value (v1);
361 }
362 }
363 PUSH (v2);
364 break;
365
366 case Bvarset+6:
367 op = FETCH;
368 goto varset;
369
370 case Bvarset+7:
371 op = FETCH2;
372 goto varset;
373
374 case Bvarset: case Bvarset+1: case Bvarset+2: case Bvarset+3:
375 case Bvarset+4: case Bvarset+5:
376 op -= Bvarset;
377 varset:
378 Fset (vectorp[op], POP);
379 break;
380
381 case Bvarbind+6:
382 op = FETCH;
383 goto varbind;
384
385 case Bvarbind+7:
386 op = FETCH2;
387 goto varbind;
388
389 case Bvarbind: case Bvarbind+1: case Bvarbind+2: case Bvarbind+3:
390 case Bvarbind+4: case Bvarbind+5:
391 op -= Bvarbind;
392 varbind:
393 specbind (vectorp[op], POP);
394 break;
395
396 case Bcall+6:
397 op = FETCH;
398 goto docall;
399
400 case Bcall+7:
401 op = FETCH2;
402 goto docall;
403
404 case Bcall: case Bcall+1: case Bcall+2: case Bcall+3:
405 case Bcall+4: case Bcall+5:
406 op -= Bcall;
407 docall:
408 DISCARD (op);
409 #ifdef BYTE_CODE_METER
410 if (byte_metering_on && XTYPE (TOP) == Lisp_Symbol)
411 {
412 v1 = TOP;
413 v2 = Fget (v1, Qbyte_code_meter);
414 if (XTYPE (v2) == Lisp_Int)
415 {
416 XSETINT (v2, XINT (v2) + 1);
417 Fput (v1, Qbyte_code_meter, v2);
418 }
419 }
420 #endif
421 TOP = Ffuncall (op + 1, &TOP);
422 break;
423
424 case Bunbind+6:
425 op = FETCH;
426 goto dounbind;
427
428 case Bunbind+7:
429 op = FETCH2;
430 goto dounbind;
431
432 case Bunbind: case Bunbind+1: case Bunbind+2: case Bunbind+3:
433 case Bunbind+4: case Bunbind+5:
434 op -= Bunbind;
435 dounbind:
436 unbind_to (specpdl_ptr - specpdl - op, Qnil);
437 break;
438
439 case Bunbind_all:
440 /* To unbind back to the beginning of this frame. Not used yet,
441 but will be needed for tail-recursion elimination. */
442 unbind_to (count, Qnil);
443 break;
444
445 case Bgoto:
446 QUIT;
447 op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
448 pc = XSTRING (string_saved)->data + op;
449 break;
450
451 case Bgotoifnil:
452 op = FETCH2;
453 if (NILP (POP))
454 {
455 QUIT;
456 pc = XSTRING (string_saved)->data + op;
457 }
458 break;
459
460 case Bgotoifnonnil:
461 op = FETCH2;
462 if (!NILP (POP))
463 {
464 QUIT;
465 pc = XSTRING (string_saved)->data + op;
466 }
467 break;
468
469 case Bgotoifnilelsepop:
470 op = FETCH2;
471 if (NILP (TOP))
472 {
473 QUIT;
474 pc = XSTRING (string_saved)->data + op;
475 }
476 else DISCARD (1);
477 break;
478
479 case Bgotoifnonnilelsepop:
480 op = FETCH2;
481 if (!NILP (TOP))
482 {
483 QUIT;
484 pc = XSTRING (string_saved)->data + op;
485 }
486 else DISCARD (1);
487 break;
488
489 case BRgoto:
490 QUIT;
491 pc += *pc - 127;
492 break;
493
494 case BRgotoifnil:
495 if (NILP (POP))
496 {
497 QUIT;
498 pc += *pc - 128;
499 }
500 pc++;
501 break;
502
503 case BRgotoifnonnil:
504 if (!NILP (POP))
505 {
506 QUIT;
507 pc += *pc - 128;
508 }
509 pc++;
510 break;
511
512 case BRgotoifnilelsepop:
513 op = *pc++;
514 if (NILP (TOP))
515 {
516 QUIT;
517 pc += op - 128;
518 }
519 else DISCARD (1);
520 break;
521
522 case BRgotoifnonnilelsepop:
523 op = *pc++;
524 if (!NILP (TOP))
525 {
526 QUIT;
527 pc += op - 128;
528 }
529 else DISCARD (1);
530 break;
531
532 case Breturn:
533 v1 = POP;
534 goto exit;
535
536 case Bdiscard:
537 DISCARD (1);
538 break;
539
540 case Bdup:
541 v1 = TOP;
542 PUSH (v1);
543 break;
544
545 case Bconstant2:
546 PUSH (vectorp[FETCH2]);
547 break;
548
549 case Bsave_excursion:
550 record_unwind_protect (save_excursion_restore, save_excursion_save ());
551 break;
552
553 case Bsave_window_excursion:
554 TOP = Fsave_window_excursion (TOP);
555 break;
556
557 case Bsave_restriction:
558 record_unwind_protect (save_restriction_restore, save_restriction_save ());
559 break;
560
561 case Bcatch:
562 v1 = POP;
563 TOP = internal_catch (TOP, Feval, v1);
564 break;
565
566 case Bunwind_protect:
567 record_unwind_protect (0, POP);
568 (specpdl_ptr - 1)->symbol = Qnil;
569 break;
570
571 case Bcondition_case:
572 v1 = POP;
573 v1 = Fcons (POP, v1);
574 TOP = Fcondition_case (Fcons (TOP, v1));
575 break;
576
577 case Btemp_output_buffer_setup:
578 temp_output_buffer_setup (XSTRING (TOP)->data);
579 TOP = Vstandard_output;
580 break;
581
582 case Btemp_output_buffer_show:
583 v1 = POP;
584 temp_output_buffer_show (TOP, Qnil);
585 TOP = v1;
586 /* pop binding of standard-output */
587 unbind_to (specpdl_ptr - specpdl - 1, Qnil);
588 break;
589
590 case Bnth:
591 v1 = POP;
592 v2 = TOP;
593 nth_entry:
594 CHECK_NUMBER (v2, 0);
595 op = XINT (v2);
596 immediate_quit = 1;
597 while (--op >= 0)
598 {
599 if (CONSP (v1))
600 v1 = XCONS (v1)->cdr;
601 else if (!NILP (v1))
602 {
603 immediate_quit = 0;
604 v1 = wrong_type_argument (Qlistp, v1);
605 immediate_quit = 1;
606 op++;
607 }
608 }
609 immediate_quit = 0;
610 goto docar;
611
612 case Bsymbolp:
613 TOP = XTYPE (TOP) == Lisp_Symbol ? Qt : Qnil;
614 break;
615
616 case Bconsp:
617 TOP = CONSP (TOP) ? Qt : Qnil;
618 break;
619
620 case Bstringp:
621 TOP = XTYPE (TOP) == Lisp_String ? Qt : Qnil;
622 break;
623
624 case Blistp:
625 TOP = CONSP (TOP) || NILP (TOP) ? Qt : Qnil;
626 break;
627
628 case Beq:
629 v1 = POP;
630 TOP = EQ (v1, TOP) ? Qt : Qnil;
631 break;
632
633 case Bmemq:
634 v1 = POP;
635 TOP = Fmemq (TOP, v1);
636 break;
637
638 case Bnot:
639 TOP = NILP (TOP) ? Qt : Qnil;
640 break;
641
642 case Bcar:
643 v1 = TOP;
644 docar:
645 if (CONSP (v1)) TOP = XCONS (v1)->car;
646 else if (NILP (v1)) TOP = Qnil;
647 else Fcar (wrong_type_argument (Qlistp, v1));
648 break;
649
650 case Bcdr:
651 v1 = TOP;
652 if (CONSP (v1)) TOP = XCONS (v1)->cdr;
653 else if (NILP (v1)) TOP = Qnil;
654 else Fcdr (wrong_type_argument (Qlistp, v1));
655 break;
656
657 case Bcons:
658 v1 = POP;
659 TOP = Fcons (TOP, v1);
660 break;
661
662 case Blist1:
663 TOP = Fcons (TOP, Qnil);
664 break;
665
666 case Blist2:
667 v1 = POP;
668 TOP = Fcons (TOP, Fcons (v1, Qnil));
669 break;
670
671 case Blist3:
672 DISCARD (2);
673 TOP = Flist (3, &TOP);
674 break;
675
676 case Blist4:
677 DISCARD (3);
678 TOP = Flist (4, &TOP);
679 break;
680
681 case BlistN:
682 op = FETCH;
683 DISCARD (op - 1);
684 TOP = Flist (op, &TOP);
685 break;
686
687 case Blength:
688 TOP = Flength (TOP);
689 break;
690
691 case Baref:
692 v1 = POP;
693 TOP = Faref (TOP, v1);
694 break;
695
696 case Baset:
697 v2 = POP; v1 = POP;
698 TOP = Faset (TOP, v1, v2);
699 break;
700
701 case Bsymbol_value:
702 TOP = Fsymbol_value (TOP);
703 break;
704
705 case Bsymbol_function:
706 TOP = Fsymbol_function (TOP);
707 break;
708
709 case Bset:
710 v1 = POP;
711 TOP = Fset (TOP, v1);
712 break;
713
714 case Bfset:
715 v1 = POP;
716 TOP = Ffset (TOP, v1);
717 break;
718
719 case Bget:
720 v1 = POP;
721 TOP = Fget (TOP, v1);
722 break;
723
724 case Bsubstring:
725 v2 = POP; v1 = POP;
726 TOP = Fsubstring (TOP, v1, v2);
727 break;
728
729 case Bconcat2:
730 DISCARD (1);
731 TOP = Fconcat (2, &TOP);
732 break;
733
734 case Bconcat3:
735 DISCARD (2);
736 TOP = Fconcat (3, &TOP);
737 break;
738
739 case Bconcat4:
740 DISCARD (3);
741 TOP = Fconcat (4, &TOP);
742 break;
743
744 case BconcatN:
745 op = FETCH;
746 DISCARD (op - 1);
747 TOP = Fconcat (op, &TOP);
748 break;
749
750 case Bsub1:
751 v1 = TOP;
752 if (XTYPE (v1) == Lisp_Int)
753 {
754 XSETINT (v1, XINT (v1) - 1);
755 TOP = v1;
756 }
757 else
758 TOP = Fsub1 (v1);
759 break;
760
761 case Badd1:
762 v1 = TOP;
763 if (XTYPE (v1) == Lisp_Int)
764 {
765 XSETINT (v1, XINT (v1) + 1);
766 TOP = v1;
767 }
768 else
769 TOP = Fadd1 (v1);
770 break;
771
772 case Beqlsign:
773 v2 = POP; v1 = TOP;
774 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1, 0);
775 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2, 0);
776 TOP = (XFLOATINT (v1) == XFLOATINT (v2)) ? Qt : Qnil;
777 break;
778
779 case Bgtr:
780 v1 = POP;
781 TOP = Fgtr (TOP, v1);
782 break;
783
784 case Blss:
785 v1 = POP;
786 TOP = Flss (TOP, v1);
787 break;
788
789 case Bleq:
790 v1 = POP;
791 TOP = Fleq (TOP, v1);
792 break;
793
794 case Bgeq:
795 v1 = POP;
796 TOP = Fgeq (TOP, v1);
797 break;
798
799 case Bdiff:
800 DISCARD (1);
801 TOP = Fminus (2, &TOP);
802 break;
803
804 case Bnegate:
805 v1 = TOP;
806 if (XTYPE (v1) == Lisp_Int)
807 {
808 XSETINT (v1, - XINT (v1));
809 TOP = v1;
810 }
811 else
812 TOP = Fminus (1, &TOP);
813 break;
814
815 case Bplus:
816 DISCARD (1);
817 TOP = Fplus (2, &TOP);
818 break;
819
820 case Bmax:
821 DISCARD (1);
822 TOP = Fmax (2, &TOP);
823 break;
824
825 case Bmin:
826 DISCARD (1);
827 TOP = Fmin (2, &TOP);
828 break;
829
830 case Bmult:
831 DISCARD (1);
832 TOP = Ftimes (2, &TOP);
833 break;
834
835 case Bquo:
836 DISCARD (1);
837 TOP = Fquo (2, &TOP);
838 break;
839
840 case Brem:
841 v1 = POP;
842 TOP = Frem (TOP, v1);
843 break;
844
845 case Bpoint:
846 XFASTINT (v1) = point;
847 PUSH (v1);
848 break;
849
850 case Bgoto_char:
851 TOP = Fgoto_char (TOP);
852 break;
853
854 case Binsert:
855 TOP = Finsert (1, &TOP);
856 break;
857
858 case BinsertN:
859 op = FETCH;
860 DISCARD (op - 1);
861 TOP = Finsert (op, &TOP);
862 break;
863
864 case Bpoint_max:
865 XFASTINT (v1) = ZV;
866 PUSH (v1);
867 break;
868
869 case Bpoint_min:
870 XFASTINT (v1) = BEGV;
871 PUSH (v1);
872 break;
873
874 case Bchar_after:
875 TOP = Fchar_after (TOP);
876 break;
877
878 case Bfollowing_char:
879 XFASTINT (v1) = PT == ZV ? 0 : FETCH_CHAR (point);
880 PUSH (v1);
881 break;
882
883 case Bpreceding_char:
884 XFASTINT (v1) = point <= BEGV ? 0 : FETCH_CHAR (point - 1);
885 PUSH (v1);
886 break;
887
888 case Bcurrent_column:
889 XFASTINT (v1) = current_column ();
890 PUSH (v1);
891 break;
892
893 case Bindent_to:
894 TOP = Findent_to (TOP, Qnil);
895 break;
896
897 case Beolp:
898 PUSH (Feolp ());
899 break;
900
901 case Beobp:
902 PUSH (Feobp ());
903 break;
904
905 case Bbolp:
906 PUSH (Fbolp ());
907 break;
908
909 case Bbobp:
910 PUSH (Fbobp ());
911 break;
912
913 case Bcurrent_buffer:
914 PUSH (Fcurrent_buffer ());
915 break;
916
917 case Bset_buffer:
918 TOP = Fset_buffer (TOP);
919 break;
920
921 case Bread_char:
922 PUSH (Fread_char ());
923 QUIT;
924 break;
925
926 case Binteractive_p:
927 PUSH (Finteractive_p ());
928 break;
929
930 case Bforward_char:
931 TOP = Fforward_char (TOP);
932 break;
933
934 case Bforward_word:
935 TOP = Fforward_word (TOP);
936 break;
937
938 case Bskip_chars_forward:
939 v1 = POP;
940 TOP = Fskip_chars_forward (TOP, v1);
941 break;
942
943 case Bskip_chars_backward:
944 v1 = POP;
945 TOP = Fskip_chars_backward (TOP, v1);
946 break;
947
948 case Bforward_line:
949 TOP = Fforward_line (TOP);
950 break;
951
952 case Bchar_syntax:
953 CHECK_NUMBER (TOP, 0);
954 XFASTINT (TOP) = syntax_code_spec[(int) SYNTAX (0xFF & XINT (TOP))];
955 break;
956
957 case Bbuffer_substring:
958 v1 = POP;
959 TOP = Fbuffer_substring (TOP, v1);
960 break;
961
962 case Bdelete_region:
963 v1 = POP;
964 TOP = Fdelete_region (TOP, v1);
965 break;
966
967 case Bnarrow_to_region:
968 v1 = POP;
969 TOP = Fnarrow_to_region (TOP, v1);
970 break;
971
972 case Bwiden:
973 PUSH (Fwiden ());
974 break;
975
976 case Bend_of_line:
977 TOP = Fend_of_line (TOP);
978 break;
979
980 case Bset_marker:
981 v1 = POP;
982 v2 = POP;
983 TOP = Fset_marker (TOP, v2, v1);
984 break;
985
986 case Bmatch_beginning:
987 TOP = Fmatch_beginning (TOP);
988 break;
989
990 case Bmatch_end:
991 TOP = Fmatch_end (TOP);
992 break;
993
994 case Bupcase:
995 TOP = Fupcase (TOP);
996 break;
997
998 case Bdowncase:
999 TOP = Fdowncase (TOP);
1000 break;
1001
1002 case Bstringeqlsign:
1003 v1 = POP;
1004 TOP = Fstring_equal (TOP, v1);
1005 break;
1006
1007 case Bstringlss:
1008 v1 = POP;
1009 TOP = Fstring_lessp (TOP, v1);
1010 break;
1011
1012 case Bequal:
1013 v1 = POP;
1014 TOP = Fequal (TOP, v1);
1015 break;
1016
1017 case Bnthcdr:
1018 v1 = POP;
1019 TOP = Fnthcdr (TOP, v1);
1020 break;
1021
1022 case Belt:
1023 if (XTYPE (TOP) == Lisp_Cons)
1024 {
1025 /* Exchange args and then do nth. */
1026 v2 = POP;
1027 v1 = TOP;
1028 goto nth_entry;
1029 }
1030 v1 = POP;
1031 TOP = Felt (TOP, v1);
1032 break;
1033
1034 case Bmember:
1035 v1 = POP;
1036 TOP = Fmember (TOP, v1);
1037 break;
1038
1039 case Bassq:
1040 v1 = POP;
1041 TOP = Fassq (TOP, v1);
1042 break;
1043
1044 case Bnreverse:
1045 TOP = Fnreverse (TOP);
1046 break;
1047
1048 case Bsetcar:
1049 v1 = POP;
1050 TOP = Fsetcar (TOP, v1);
1051 break;
1052
1053 case Bsetcdr:
1054 v1 = POP;
1055 TOP = Fsetcdr (TOP, v1);
1056 break;
1057
1058 case Bcar_safe:
1059 v1 = TOP;
1060 if (XTYPE (v1) == Lisp_Cons)
1061 TOP = XCONS (v1)->car;
1062 else
1063 TOP = Qnil;
1064 break;
1065
1066 case Bcdr_safe:
1067 v1 = TOP;
1068 if (XTYPE (v1) == Lisp_Cons)
1069 TOP = XCONS (v1)->cdr;
1070 else
1071 TOP = Qnil;
1072 break;
1073
1074 case Bnconc:
1075 DISCARD (1);
1076 TOP = Fnconc (2, &TOP);
1077 break;
1078
1079 case Bnumberp:
1080 TOP = (XTYPE (TOP) == Lisp_Int || XTYPE (TOP) == Lisp_Float
1081 ? Qt : Qnil);
1082 break;
1083
1084 case Bintegerp:
1085 TOP = XTYPE (TOP) == Lisp_Int ? Qt : Qnil;
1086 break;
1087
1088 #ifdef BYTE_CODE_SAFE
1089 case Bset_mark:
1090 error ("set-mark is an obsolete bytecode");
1091 break;
1092 case Bscan_buffer:
1093 error ("scan-buffer is an obsolete bytecode");
1094 break;
1095 case Bmark:
1096 error ("mark is an obsolete bytecode");
1097 break;
1098 #endif
1099
1100 default:
1101 #ifdef BYTE_CODE_SAFE
1102 if (op < Bconstant)
1103 error ("unknown bytecode %d (byte compiler bug)", op);
1104 if ((op -= Bconstant) >= const_length)
1105 error ("no constant number %d (byte compiler bug)", op);
1106 PUSH (vectorp[op]);
1107 #else
1108 PUSH (vectorp[op - Bconstant]);
1109 #endif
1110 }
1111 }
1112
1113 exit:
1114 UNGCPRO;
1115 /* Binds and unbinds are supposed to be compiled balanced. */
1116 if (specpdl_ptr - specpdl != count)
1117 #ifdef BYTE_CODE_SAFE
1118 error ("binding stack not balanced (serious byte compiler bug)");
1119 #else
1120 abort ();
1121 #endif
1122 return v1;
1123 }
1124
1125 syms_of_bytecode ()
1126 {
1127 Qbytecode = intern ("byte-code");
1128 staticpro (&Qbytecode);
1129
1130 defsubr (&Sbyte_code);
1131
1132 #ifdef BYTE_CODE_METER
1133
1134 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter,
1135 "A vector of vectors which holds a histogram of byte-code usage.");
1136 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on, "");
1137
1138 byte_metering_on = 0;
1139 Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
1140 Qbyte_code_meter = intern ("byte-code-meter");
1141 staticpro (&Qbyte_code_meter);
1142 {
1143 int i = 256;
1144 while (i--)
1145 XVECTOR (Vbyte_code_meter)->contents[i] =
1146 Fmake_vector (make_number (256), make_number (0));
1147 }
1148 #endif
1149 }