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