Mercurial > hg > xemacs-beta

comparison src/bytecode.c @ 0:376386a54a3c r19-14

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