git.chise.org Git - chise/xemacs-chise.git.1/blob - src/bytecode.c

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