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