src/bytecode.c

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