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

   1 /* Execution of byte code produced by bytecomp.el.
   2    Implementation of compiled-function objects.
   3    Copyright (C) 1992, 1993 Free Software Foundation, Inc.
   4
   5 This file is part of XEmacs.
   6
   7 XEmacs is free software; you can redistribute it and/or modify it
   8 under the terms of the GNU General Public License as published by the
   9 Free Software Foundation; either version 2, or (at your option) any
  10 later version.
  11
  12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with XEmacs; see the file COPYING.  If not, write to
  19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 Boston, MA 02111-1307, USA.  */
  21
  22 /* Synched up with: Mule 2.0, FSF 19.30. */
  23
  24 /* This file has been Mule-ized. */
  25
  26
  27 /* Authorship:
  28
  29    FSF: long ago.
  30
  31 hacked on by jwz@jwz.org 1991-06
  32   o  added a compile-time switch to turn on simple sanity checking;
  33   o  put back the obsolete byte-codes for error-detection;
  34   o  added a new instruction, unbind_all, which I will use for
  35      tail-recursion elimination;
  36   o  made temp_output_buffer_show be called with the right number
  37      of args;
  38   o  made the new bytecodes be called with args in the right order;
  39   o  added metering support.
  40
  41 by Hallvard:
  42   o  added relative jump instructions;
  43   o  all conditionals now only do QUIT if they jump.
  44
  45    Ben Wing: some changes for Mule, 1995-06.
  46
  47    Martin Buchholz: performance hacking, 1998-09.
  48    See Internals Manual, Evaluation.
  49  */
  50
  51 #include <config.h>
  52 #include "lisp.h"
  53 #include "backtrace.h"
  54 #include "buffer.h"
  55 #include "bytecode.h"
  56 #include "opaque.h"
  57 #include "syntax.h"
  58
  59 EXFUN (Ffetch_bytecode, 1);
  60
  61 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
  62
  63 enum Opcode /* Byte codes */
  64 {
  65   Bvarref               = 010,
  66   Bvarset               = 020,
  67   Bvarbind              = 030,
  68   Bcall                 = 040,
  69   Bunbind               = 050,
  70
  71   Bnth                  = 070,
  72   Bsymbolp              = 071,
  73   Bconsp                = 072,
  74   Bstringp              = 073,
  75   Blistp                = 074,
  76   Bold_eq               = 075,
  77   Bold_memq             = 076,
  78   Bnot                  = 077,
  79   Bcar                  = 0100,
  80   Bcdr                  = 0101,
  81   Bcons                 = 0102,
  82   Blist1                = 0103,
  83   Blist2                = 0104,
  84   Blist3                = 0105,
  85   Blist4                = 0106,
  86   Blength               = 0107,
  87   Baref                 = 0110,
  88   Baset                 = 0111,
  89   Bsymbol_value         = 0112,
  90   Bsymbol_function      = 0113,
  91   Bset                  = 0114,
  92   Bfset                 = 0115,
  93   Bget                  = 0116,
  94   Bsubstring            = 0117,
  95   Bconcat2              = 0120,
  96   Bconcat3              = 0121,
  97   Bconcat4              = 0122,
  98   Bsub1                 = 0123,
  99   Badd1                 = 0124,
 100   Beqlsign              = 0125,
 101   Bgtr                  = 0126,
 102   Blss                  = 0127,
 103   Bleq                  = 0130,
 104   Bgeq                  = 0131,
 105   Bdiff                 = 0132,
 106   Bnegate               = 0133,
 107   Bplus                 = 0134,
 108   Bmax                  = 0135,
 109   Bmin                  = 0136,
 110   Bmult                 = 0137,
 111
 112   Bpoint                = 0140,
 113   Beq                   = 0141, /* was Bmark,
 114                                    but no longer generated as of v18 */
 115   Bgoto_char            = 0142,
 116   Binsert               = 0143,
 117   Bpoint_max            = 0144,
 118   Bpoint_min            = 0145,
 119   Bchar_after           = 0146,
 120   Bfollowing_char       = 0147,
 121   Bpreceding_char       = 0150,
 122   Bcurrent_column       = 0151,
 123   Bindent_to            = 0152,
 124   Bequal                = 0153, /* was Bscan_buffer,
 125                                    but no longer generated as of v18 */
 126   Beolp                 = 0154,
 127   Beobp                 = 0155,
 128   Bbolp                 = 0156,
 129   Bbobp                 = 0157,
 130   Bcurrent_buffer       = 0160,
 131   Bset_buffer           = 0161,
 132   Bsave_current_buffer  = 0162, /* was Bread_char,
 133                                    but no longer generated as of v19 */
 134   Bmemq                 = 0163, /* was Bset_mark,
 135                                    but no longer generated as of v18 */
 136   Binteractive_p        = 0164, /* Needed since interactive-p takes
 137                                    unevalled args */
 138   Bforward_char         = 0165,
 139   Bforward_word         = 0166,
 140   Bskip_chars_forward   = 0167,
 141   Bskip_chars_backward  = 0170,
 142   Bforward_line         = 0171,
 143   Bchar_syntax          = 0172,
 144   Bbuffer_substring     = 0173,
 145   Bdelete_region        = 0174,
 146   Bnarrow_to_region     = 0175,
 147   Bwiden                = 0176,
 148   Bend_of_line          = 0177,
 149
 150   Bconstant2            = 0201,
 151   Bgoto                 = 0202,
 152   Bgotoifnil            = 0203,
 153   Bgotoifnonnil         = 0204,
 154   Bgotoifnilelsepop     = 0205,
 155   Bgotoifnonnilelsepop  = 0206,
 156   Breturn               = 0207,
 157   Bdiscard              = 0210,
 158   Bdup                  = 0211,
 159
 160   Bsave_excursion       = 0212,
 161   Bsave_window_excursion= 0213,
 162   Bsave_restriction     = 0214,
 163   Bcatch                = 0215,
 164
 165   Bunwind_protect       = 0216,
 166   Bcondition_case       = 0217,
 167   Btemp_output_buffer_setup = 0220,
 168   Btemp_output_buffer_show  = 0221,
 169
 170   Bunbind_all           = 0222,
 171
 172   Bset_marker           = 0223,
 173   Bmatch_beginning      = 0224,
 174   Bmatch_end            = 0225,
 175   Bupcase               = 0226,
 176   Bdowncase             = 0227,
 177
 178   Bstring_equal         = 0230,
 179   Bstring_lessp         = 0231,
 180   Bold_equal            = 0232,
 181   Bnthcdr               = 0233,
 182   Belt                  = 0234,
 183   Bold_member           = 0235,
 184   Bold_assq             = 0236,
 185   Bnreverse             = 0237,
 186   Bsetcar               = 0240,
 187   Bsetcdr               = 0241,
 188   Bcar_safe             = 0242,
 189   Bcdr_safe             = 0243,
 190   Bnconc                = 0244,
 191   Bquo                  = 0245,
 192   Brem                  = 0246,
 193   Bnumberp              = 0247,
 194   Bintegerp             = 0250,
 195
 196   BRgoto                = 0252,
 197   BRgotoifnil           = 0253,
 198   BRgotoifnonnil        = 0254,
 199   BRgotoifnilelsepop    = 0255,
 200   BRgotoifnonnilelsepop = 0256,
 201
 202   BlistN                = 0257,
 203   BconcatN              = 0260,
 204   BinsertN              = 0261,
 205   Bmember               = 0266, /* new in v20 */
 206   Bassq                 = 0267, /* new in v20 */
 207
 208   Bconstant             = 0300
 209 };
 210 typedef enum Opcode Opcode;
 211 typedef unsigned char Opbyte;
 212 \f
 213
 214 static void invalid_byte_code_error (char *error_message, ...);
 215
 216 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
 217                                    const Opbyte *program_ptr,
 218                                    Opcode opcode);
 219
 220 static Lisp_Object execute_optimized_program (const Opbyte *program,
 221                                               int stack_depth,
 222                                               Lisp_Object *constants_data);
 223
 224 extern Lisp_Object Qand_rest, Qand_optional;
 225
 226 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
 227    This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
 228 /* #define BYTE_CODE_METER */
 229
 230 \f
 231 #ifdef BYTE_CODE_METER
 232
 233 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
 234 int byte_metering_on;
 235
 236 static void
 237 meter_code (Opcode prev_opcode, Opcode this_opcode)
 238 {
 239   if (byte_metering_on)
 240     {
 241       Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]);
 242       p[0] = INT_PLUS1 (p[0]);
 243       if (prev_opcode)
 244         p[prev_opcode] = INT_PLUS1 (p[prev_opcode]);
 245     }
 246 }
 247
 248 #endif /* BYTE_CODE_METER */
 249
 250 \f
 251 static Lisp_Object
 252 bytecode_negate (Lisp_Object obj)
 253 {
 254  retry:
 255
 256   if (INTP    (obj)) return make_int (- XINT (obj));
 257 #ifdef LISP_FLOAT_TYPE
 258   if (FLOATP  (obj)) return make_float (- XFLOAT_DATA (obj));
 259 #endif
 260   if (CHARP   (obj)) return make_int (- ((int) XCHAR (obj)));
 261   if (MARKERP (obj)) return make_int (- ((int) marker_position (obj)));
 262
 263   obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
 264   goto retry;
 265 }
 266
 267 static Lisp_Object
 268 bytecode_nreverse (Lisp_Object list)
 269 {
 270   REGISTER Lisp_Object prev = Qnil;
 271   REGISTER Lisp_Object tail = list;
 272
 273   while (!NILP (tail))
 274     {
 275       REGISTER Lisp_Object next;
 276       CHECK_CONS (tail);
 277       next = XCDR (tail);
 278       XCDR (tail) = prev;
 279       prev = tail;
 280       tail = next;
 281     }
 282   return prev;
 283 }
 284
 285
 286 /* We have our own two-argument versions of various arithmetic ops.
 287    Only two-argument arithmetic operations have their own byte codes. */
 288 static int
 289 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2)
 290 {
 291   retry:
 292
 293 #ifdef LISP_FLOAT_TYPE
 294   {
 295     EMACS_INT ival1, ival2;
 296
 297     if      (INTP    (obj1)) ival1 = XINT  (obj1);
 298     else if (CHARP   (obj1)) ival1 = XCHAR (obj1);
 299     else if (MARKERP (obj1)) ival1 = marker_position (obj1);
 300     else goto arithcompare_float;
 301
 302     if      (INTP    (obj2)) ival2 = XINT  (obj2);
 303     else if (CHARP   (obj2)) ival2 = XCHAR (obj2);
 304     else if (MARKERP (obj2)) ival2 = marker_position (obj2);
 305     else goto arithcompare_float;
 306
 307     return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
 308   }
 309
 310  arithcompare_float:
 311
 312   {
 313     double dval1, dval2;
 314
 315     if      (FLOATP  (obj1)) dval1 = XFLOAT_DATA (obj1);
 316     else if (INTP    (obj1)) dval1 = (double) XINT  (obj1);
 317     else if (CHARP   (obj1)) dval1 = (double) XCHAR (obj1);
 318     else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1);
 319     else
 320       {
 321         obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
 322         goto retry;
 323       }
 324
 325     if      (FLOATP  (obj2)) dval2 = XFLOAT_DATA (obj2);
 326     else if (INTP    (obj2)) dval2 = (double) XINT  (obj2);
 327     else if (CHARP   (obj2)) dval2 = (double) XCHAR (obj2);
 328     else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2);
 329     else
 330       {
 331         obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
 332         goto retry;
 333       }
 334
 335     return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
 336   }
 337 #else /* !LISP_FLOAT_TYPE */
 338   {
 339     EMACS_INT ival1, ival2;
 340
 341     if      (INTP    (obj1)) ival1 = XINT  (obj1);
 342     else if (CHARP   (obj1)) ival1 = XCHAR (obj1);
 343     else if (MARKERP (obj1)) ival1 = marker_position (obj1);
 344     else
 345       {
 346         obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
 347         goto retry;
 348       }
 349
 350     if      (INTP    (obj2)) ival2 = XINT  (obj2);
 351     else if (CHARP   (obj2)) ival2 = XCHAR (obj2);
 352     else if (MARKERP (obj2)) ival2 = marker_position (obj2);
 353     else
 354       {
 355         obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
 356         goto retry;
 357       }
 358
 359     return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
 360   }
 361 #endif /* !LISP_FLOAT_TYPE */
 362 }
 363
 364 static Lisp_Object
 365 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
 366 {
 367 #ifdef LISP_FLOAT_TYPE
 368   EMACS_INT ival1, ival2;
 369   int float_p;
 370
 371  retry:
 372
 373   float_p = 0;
 374
 375   if      (INTP    (obj1)) ival1 = XINT  (obj1);
 376   else if (CHARP   (obj1)) ival1 = XCHAR (obj1);
 377   else if (MARKERP (obj1)) ival1 = marker_position (obj1);
 378   else if (FLOATP  (obj1)) ival1 = 0, float_p = 1;
 379   else
 380     {
 381       obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
 382       goto retry;
 383     }
 384
 385   if      (INTP    (obj2)) ival2 = XINT  (obj2);
 386   else if (CHARP   (obj2)) ival2 = XCHAR (obj2);
 387   else if (MARKERP (obj2)) ival2 = marker_position (obj2);
 388   else if (FLOATP  (obj2)) ival2 = 0, float_p = 1;
 389   else
 390     {
 391       obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
 392       goto retry;
 393     }
 394
 395   if (!float_p)
 396     {
 397       switch (opcode)
 398         {
 399         case Bplus: ival1 += ival2; break;
 400         case Bdiff: ival1 -= ival2; break;
 401         case Bmult: ival1 *= ival2; break;
 402         case Bquo:
 403           if (ival2 == 0) Fsignal (Qarith_error, Qnil);
 404           ival1 /= ival2;
 405           break;
 406         case Bmax:  if (ival1 < ival2) ival1 = ival2; break;
 407         case Bmin:  if (ival1 > ival2) ival1 = ival2; break;
 408         }
 409       return make_int (ival1);
 410     }
 411   else
 412     {
 413       double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1;
 414       double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2;
 415       switch (opcode)
 416         {
 417         case Bplus: dval1 += dval2; break;
 418         case Bdiff: dval1 -= dval2; break;
 419         case Bmult: dval1 *= dval2; break;
 420         case Bquo:
 421           if (dval2 == 0) Fsignal (Qarith_error, Qnil);
 422           dval1 /= dval2;
 423           break;
 424         case Bmax:  if (dval1 < dval2) dval1 = dval2; break;
 425         case Bmin:  if (dval1 > dval2) dval1 = dval2; break;
 426         }
 427       return make_float (dval1);
 428     }
 429 #else /* !LISP_FLOAT_TYPE */
 430   EMACS_INT ival1, ival2;
 431
 432  retry:
 433
 434   if      (INTP    (obj1)) ival1 = XINT  (obj1);
 435   else if (CHARP   (obj1)) ival1 = XCHAR (obj1);
 436   else if (MARKERP (obj1)) ival1 = marker_position (obj1);
 437   else
 438     {
 439       obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
 440       goto retry;
 441     }
 442
 443   if      (INTP    (obj2)) ival2 = XINT  (obj2);
 444   else if (CHARP   (obj2)) ival2 = XCHAR (obj2);
 445   else if (MARKERP (obj2)) ival2 = marker_position (obj2);
 446   else
 447     {
 448       obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
 449       goto retry;
 450     }
 451
 452   switch (opcode)
 453     {
 454     case Bplus: ival1 += ival2; break;
 455     case Bdiff: ival1 -= ival2; break;
 456     case Bmult: ival1 *= ival2; break;
 457     case Bquo:
 458       if (ival2 == 0) Fsignal (Qarith_error, Qnil);
 459       ival1 /= ival2;
 460       break;
 461     case Bmax:  if (ival1 < ival2) ival1 = ival2; break;
 462     case Bmin:  if (ival1 > ival2) ival1 = ival2; break;
 463     }
 464   return make_int (ival1);
 465 #endif /* !LISP_FLOAT_TYPE */
 466 }
 467
 468 /* Apply compiled-function object FUN to the NARGS evaluated arguments
 469    in ARGS, and return the result of evaluation. */
 470 Lisp_Object
 471 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[])
 472 {
 473   /* This function can GC */
 474   Lisp_Object symbol, tail;
 475   int speccount = specpdl_depth();
 476   REGISTER int i = 0;
 477   Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
 478   int optional = 0;
 479
 480   if (!OPAQUEP (f->instructions))
 481     /* Lazily munge the instructions into a more efficient form */
 482     optimize_compiled_function (fun);
 483
 484   /* optimize_compiled_function() guaranteed that f->specpdl_depth is
 485      the required space on the specbinding stack for binding the args
 486      and local variables of fun.   So just reserve it once. */
 487   SPECPDL_RESERVE (f->specpdl_depth);
 488
 489   /* Fmake_byte_code() guaranteed that f->arglist is a valid list
 490      containing only non-constant symbols. */
 491   LIST_LOOP_3 (symbol, f->arglist, tail)
 492     {
 493       if (EQ (symbol, Qand_rest))
 494         {
 495           tail = XCDR (tail);
 496           symbol  = XCAR (tail);
 497           SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i]));
 498           goto run_code;
 499         }
 500       else if (EQ (symbol, Qand_optional))
 501         optional = 1;
 502       else if (i == nargs && !optional)
 503         goto wrong_number_of_arguments;
 504       else
 505         SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil);
 506     }
 507
 508   if (i < nargs)
 509     goto wrong_number_of_arguments;
 510
 511  run_code:
 512
 513   {
 514     Lisp_Object value =
 515       execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions),
 516                                  f->stack_depth,
 517                                  XVECTOR_DATA (f->constants));
 518
 519     /* The attempt to optimize this by only unbinding variables failed
 520        because using buffer-local variables as function parameters
 521        leads to specpdl_ptr->func != 0 */
 522     /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */
 523     UNBIND_TO_GCPRO (speccount, value);
 524     return value;
 525   }
 526
 527  wrong_number_of_arguments:
 528   /* The actual printed compiled_function object is incomprehensible.
 529      Check the backtrace to see if we can get a more meaningful symbol. */
 530   if (EQ (fun, indirect_function (*backtrace_list->function, 0)))
 531     fun = *backtrace_list->function;
 532   return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
 533 }
 534
 535 \f
 536 /* Read next uint8 from the instruction stream. */
 537 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
 538
 539 /* Read next uint16 from the instruction stream. */
 540 #define READ_UINT_2                                             \
 541   (program_ptr += 2,                                            \
 542    (((unsigned int) (unsigned char) program_ptr[-1]) * 256 +    \
 543     ((unsigned int) (unsigned char) program_ptr[-2])))
 544
 545 /* Read next int8 from the instruction stream. */
 546 #define READ_INT_1 ((int) (signed char) *program_ptr++)
 547
 548 /* Read next int16 from the instruction stream. */
 549 #define READ_INT_2                                      \
 550   (program_ptr += 2,                                    \
 551    (((int) (  signed char) program_ptr[-1]) * 256 +     \
 552     ((int) (unsigned char) program_ptr[-2])))
 553
 554 /* Read next int8 from instruction stream; don't advance program_pointer */
 555 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
 556
 557 /* Read next int16 from instruction stream; don't advance program_pointer */
 558 #define PEEK_INT_2                                      \
 559   ((((int) (  signed char) program_ptr[1]) * 256) |     \
 560     ((int) (unsigned char) program_ptr[0]))
 561
 562 /* Do relative jumps from the current location.
 563    We only do a QUIT if we jump backwards, for efficiency.
 564    No infloops without backward jumps! */
 565 #define JUMP_RELATIVE(jump) do {        \
 566   int JR_jump = (jump);                 \
 567   if (JR_jump < 0) QUIT;                \
 568   program_ptr += JR_jump;               \
 569 } while (0)
 570
 571 #define JUMP  JUMP_RELATIVE (PEEK_INT_2)
 572 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
 573
 574 #define JUMP_NEXT  ((void) (program_ptr += 2))
 575 #define JUMPR_NEXT ((void) (program_ptr += 1))
 576
 577 /* Push x onto the execution stack. */
 578 #define PUSH(x) (*++stack_ptr = (x))
 579
 580 /* Pop a value off the execution stack. */
 581 #define POP (*stack_ptr--)
 582
 583 /* Discard n values from the execution stack.  */
 584 #define DISCARD(n) (stack_ptr -= (n))
 585
 586 /* Get the value which is at the top of the execution stack,
 587    but don't pop it. */
 588 #define TOP (*stack_ptr)
 589
 590 /* The actual interpreter for byte code.
 591    This function has been seriously optimized for performance.
 592    Don't change the constructs unless you are willing to do
 593    real benchmarking and profiling work -- martin */
 594
 595
 596 static Lisp_Object
 597 execute_optimized_program (const Opbyte *program,
 598                            int stack_depth,
 599                            Lisp_Object *constants_data)
 600 {
 601   /* This function can GC */
 602   REGISTER const Opbyte *program_ptr = (Opbyte *) program;
 603   REGISTER Lisp_Object *stack_ptr
 604     = alloca_array (Lisp_Object, stack_depth + 1);
 605   int speccount = specpdl_depth ();
 606   struct gcpro gcpro1;
 607
 608 #ifdef BYTE_CODE_METER
 609   Opcode this_opcode = 0;
 610   Opcode prev_opcode;
 611 #endif
 612
 613 #ifdef ERROR_CHECK_BYTE_CODE
 614   Lisp_Object *stack_beg = stack_ptr;
 615   Lisp_Object *stack_end = stack_beg + stack_depth;
 616 #endif
 617
 618   /* Initialize all the objects on the stack to Qnil,
 619      so we can GCPRO the whole stack.
 620      The first element of the stack is actually a dummy. */
 621   {
 622     int i;
 623     Lisp_Object *p;
 624     for (i = stack_depth, p = stack_ptr; i--;)
 625       *++p = Qnil;
 626   }
 627
 628   GCPRO1 (stack_ptr[1]);
 629   gcpro1.nvars = stack_depth;
 630
 631   while (1)
 632     {
 633       REGISTER Opcode opcode = (Opcode) READ_UINT_1;
 634 #ifdef ERROR_CHECK_BYTE_CODE
 635       if (stack_ptr > stack_end)
 636         invalid_byte_code_error ("byte code stack overflow");
 637       if (stack_ptr < stack_beg)
 638         invalid_byte_code_error ("byte code stack underflow");
 639 #endif
 640
 641 #ifdef BYTE_CODE_METER
 642       prev_opcode = this_opcode;
 643       this_opcode = opcode;
 644       meter_code (prev_opcode, this_opcode);
 645 #endif
 646
 647       switch (opcode)
 648         {
 649           REGISTER int n;
 650
 651         default:
 652           if (opcode >= Bconstant)
 653             PUSH (constants_data[opcode - Bconstant]);
 654           else
 655             stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode);
 656           break;
 657
 658         case Bvarref:
 659         case Bvarref+1:
 660         case Bvarref+2:
 661         case Bvarref+3:
 662         case Bvarref+4:
 663         case Bvarref+5: n = opcode - Bvarref; goto do_varref;
 664         case Bvarref+7: n = READ_UINT_2;      goto do_varref;
 665         case Bvarref+6: n = READ_UINT_1; /* most common */
 666         do_varref:
 667         {
 668           Lisp_Object symbol = constants_data[n];
 669           Lisp_Object value = XSYMBOL (symbol)->value;
 670           if (SYMBOL_VALUE_MAGIC_P (value))
 671             value = Fsymbol_value (symbol);
 672           PUSH (value);
 673           break;
 674         }
 675
 676         case Bvarset:
 677         case Bvarset+1:
 678         case Bvarset+2:
 679         case Bvarset+3:
 680         case Bvarset+4:
 681         case Bvarset+5: n = opcode - Bvarset; goto do_varset;
 682         case Bvarset+7: n = READ_UINT_2;      goto do_varset;
 683         case Bvarset+6: n = READ_UINT_1; /* most common */
 684         do_varset:
 685         {
 686           Lisp_Object symbol = constants_data[n];
 687           Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
 688           Lisp_Object old_value = symbol_ptr->value;
 689           Lisp_Object new_value = POP;
 690           if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
 691             symbol_ptr->value = new_value;
 692           else
 693             Fset (symbol, new_value);
 694           break;
 695         }
 696
 697         case Bvarbind:
 698         case Bvarbind+1:
 699         case Bvarbind+2:
 700         case Bvarbind+3:
 701         case Bvarbind+4:
 702         case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind;
 703         case Bvarbind+7: n = READ_UINT_2;       goto do_varbind;
 704         case Bvarbind+6: n = READ_UINT_1; /* most common */
 705         do_varbind:
 706         {
 707           Lisp_Object symbol = constants_data[n];
 708           Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
 709           Lisp_Object old_value = symbol_ptr->value;
 710           Lisp_Object new_value = POP;
 711           if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
 712             {
 713               specpdl_ptr->symbol    = symbol;
 714               specpdl_ptr->old_value = old_value;
 715               specpdl_ptr->func      = 0;
 716               specpdl_ptr++;
 717               specpdl_depth_counter++;
 718
 719               symbol_ptr->value = new_value;
 720             }
 721           else
 722             specbind_magic (symbol, new_value);
 723           break;
 724         }
 725
 726         case Bcall:
 727         case Bcall+1:
 728         case Bcall+2:
 729         case Bcall+3:
 730         case Bcall+4:
 731         case Bcall+5:
 732         case Bcall+6:
 733         case Bcall+7:
 734           n = (opcode <  Bcall+6 ? opcode - Bcall :
 735                opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2);
 736           DISCARD (n);
 737 #ifdef BYTE_CODE_METER
 738           if (byte_metering_on && SYMBOLP (TOP))
 739             {
 740               Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil);
 741               if (INTP (val))
 742                 Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
 743             }
 744 #endif
 745           TOP = Ffuncall (n + 1, &TOP);
 746           break;
 747
 748         case Bunbind:
 749         case Bunbind+1:
 750         case Bunbind+2:
 751         case Bunbind+3:
 752         case Bunbind+4:
 753         case Bunbind+5:
 754         case Bunbind+6:
 755         case Bunbind+7:
 756           UNBIND_TO (specpdl_depth() -
 757                      (opcode <  Bunbind+6 ? opcode-Bunbind :
 758                       opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
 759           break;
 760
 761
 762         case Bgoto:
 763           JUMP;
 764           break;
 765
 766         case Bgotoifnil:
 767           if (NILP (POP))
 768             JUMP;
 769           else
 770             JUMP_NEXT;
 771           break;
 772
 773         case Bgotoifnonnil:
 774           if (!NILP (POP))
 775             JUMP;
 776           else
 777             JUMP_NEXT;
 778           break;
 779
 780         case Bgotoifnilelsepop:
 781           if (NILP (TOP))
 782             JUMP;
 783           else
 784             {
 785               DISCARD (1);
 786               JUMP_NEXT;
 787             }
 788           break;
 789
 790         case Bgotoifnonnilelsepop:
 791           if (!NILP (TOP))
 792             JUMP;
 793           else
 794             {
 795               DISCARD (1);
 796               JUMP_NEXT;
 797             }
 798           break;
 799
 800
 801         case BRgoto:
 802           JUMPR;
 803           break;
 804
 805         case BRgotoifnil:
 806           if (NILP (POP))
 807             JUMPR;
 808           else
 809             JUMPR_NEXT;
 810           break;
 811
 812         case BRgotoifnonnil:
 813           if (!NILP (POP))
 814             JUMPR;
 815           else
 816             JUMPR_NEXT;
 817           break;
 818
 819         case BRgotoifnilelsepop:
 820           if (NILP (TOP))
 821             JUMPR;
 822           else
 823             {
 824               DISCARD (1);
 825               JUMPR_NEXT;
 826             }
 827           break;
 828
 829         case BRgotoifnonnilelsepop:
 830           if (!NILP (TOP))
 831             JUMPR;
 832           else
 833             {
 834               DISCARD (1);
 835               JUMPR_NEXT;
 836             }
 837           break;
 838
 839         case Breturn:
 840           UNGCPRO;
 841 #ifdef ERROR_CHECK_BYTE_CODE
 842           /* Binds and unbinds are supposed to be compiled balanced.  */
 843           if (specpdl_depth() != speccount)
 844             invalid_byte_code_error ("unbalanced specbinding stack");
 845 #endif
 846           return TOP;
 847
 848         case Bdiscard:
 849           DISCARD (1);
 850           break;
 851
 852         case Bdup:
 853           {
 854             Lisp_Object arg = TOP;
 855             PUSH (arg);
 856             break;
 857           }
 858
 859         case Bconstant2:
 860           PUSH (constants_data[READ_UINT_2]);
 861           break;
 862
 863         case Bcar:
 864           TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
 865           break;
 866
 867         case Bcdr:
 868           TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
 869           break;
 870
 871
 872         case Bunbind_all:
 873           /* To unbind back to the beginning of this frame.  Not used yet,
 874              but will be needed for tail-recursion elimination. */
 875           unbind_to (speccount, Qnil);
 876           break;
 877
 878         case Bnth:
 879           {
 880             Lisp_Object arg = POP;
 881             TOP = Fcar (Fnthcdr (TOP, arg));
 882             break;
 883           }
 884
 885         case Bsymbolp:
 886           TOP = SYMBOLP (TOP) ? Qt : Qnil;
 887           break;
 888
 889         case Bconsp:
 890           TOP = CONSP (TOP) ? Qt : Qnil;
 891           break;
 892
 893         case Bstringp:
 894           TOP = STRINGP (TOP) ? Qt : Qnil;
 895           break;
 896
 897         case Blistp:
 898           TOP = LISTP (TOP) ? Qt : Qnil;
 899           break;
 900
 901         case Bnumberp:
 902           TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
 903           break;
 904
 905         case Bintegerp:
 906           TOP = INTP (TOP) ? Qt : Qnil;
 907           break;
 908
 909         case Beq:
 910           {
 911             Lisp_Object arg = POP;
 912             TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
 913             break;
 914           }
 915
 916         case Bnot:
 917           TOP = NILP (TOP) ? Qt : Qnil;
 918           break;
 919
 920         case Bcons:
 921           {
 922             Lisp_Object arg = POP;
 923             TOP = Fcons (TOP, arg);
 924             break;
 925           }
 926
 927         case Blist1:
 928           TOP = Fcons (TOP, Qnil);
 929           break;
 930
 931
 932         case BlistN:
 933           n = READ_UINT_1;
 934           goto do_list;
 935
 936         case Blist2:
 937         case Blist3:
 938         case Blist4:
 939           /* common case */
 940           n = opcode - (Blist1 - 1);
 941         do_list:
 942           {
 943             Lisp_Object list = Qnil;
 944           list_loop:
 945             list = Fcons (TOP, list);
 946             if (--n)
 947               {
 948                 DISCARD (1);
 949                 goto list_loop;
 950               }
 951             TOP = list;
 952             break;
 953           }
 954
 955
 956         case Bconcat2:
 957         case Bconcat3:
 958         case Bconcat4:
 959           n = opcode - (Bconcat2 - 2);
 960           goto do_concat;
 961
 962         case BconcatN:
 963           /* common case */
 964           n = READ_UINT_1;
 965         do_concat:
 966           DISCARD (n - 1);
 967           TOP = Fconcat (n, &TOP);
 968           break;
 969
 970
 971         case Blength:
 972           TOP = Flength (TOP);
 973           break;
 974
 975         case Baset:
 976           {
 977             Lisp_Object arg2 = POP;
 978             Lisp_Object arg1 = POP;
 979             TOP = Faset (TOP, arg1, arg2);
 980             break;
 981           }
 982
 983         case Bsymbol_value:
 984           TOP = Fsymbol_value (TOP);
 985           break;
 986
 987         case Bsymbol_function:
 988           TOP = Fsymbol_function (TOP);
 989           break;
 990
 991         case Bget:
 992           {
 993             Lisp_Object arg = POP;
 994             TOP = Fget (TOP, arg, Qnil);
 995             break;
 996           }
 997
 998         case Bsub1:
 999           TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
1000           break;
1001
1002         case Badd1:
1003           TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
1004           break;
1005
1006
1007         case Beqlsign:
1008           {
1009             Lisp_Object arg = POP;
1010             TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
1011             break;
1012           }
1013
1014         case Bgtr:
1015           {
1016             Lisp_Object arg = POP;
1017             TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
1018             break;
1019           }
1020
1021         case Blss:
1022           {
1023             Lisp_Object arg = POP;
1024             TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
1025             break;
1026           }
1027
1028         case Bleq:
1029           {
1030             Lisp_Object arg = POP;
1031             TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
1032             break;
1033           }
1034
1035         case Bgeq:
1036           {
1037             Lisp_Object arg = POP;
1038             TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
1039             break;
1040           }
1041
1042
1043         case Bnegate:
1044           TOP = bytecode_negate (TOP);
1045           break;
1046
1047         case Bnconc:
1048           DISCARD (1);
1049           TOP = bytecode_nconc2 (&TOP);
1050           break;
1051
1052         case Bplus:
1053           {
1054             Lisp_Object arg2 = POP;
1055             Lisp_Object arg1 = TOP;
1056             TOP = INTP (arg1) && INTP (arg2) ?
1057               INT_PLUS (arg1, arg2) :
1058               bytecode_arithop (arg1, arg2, opcode);
1059             break;
1060           }
1061
1062         case Bdiff:
1063           {
1064             Lisp_Object arg2 = POP;
1065             Lisp_Object arg1 = TOP;
1066             TOP = INTP (arg1) && INTP (arg2) ?
1067               INT_MINUS (arg1, arg2) :
1068               bytecode_arithop (arg1, arg2, opcode);
1069             break;
1070           }
1071
1072         case Bmult:
1073         case Bquo:
1074         case Bmax:
1075         case Bmin:
1076           {
1077             Lisp_Object arg = POP;
1078             TOP = bytecode_arithop (TOP, arg, opcode);
1079             break;
1080           }
1081
1082         case Bpoint:
1083           PUSH (make_int (BUF_PT (current_buffer)));
1084           break;
1085
1086         case Binsert:
1087           TOP = Finsert (1, &TOP);
1088           break;
1089
1090         case BinsertN:
1091           n = READ_UINT_1;
1092           DISCARD (n - 1);
1093           TOP = Finsert (n, &TOP);
1094           break;
1095
1096         case Baref:
1097           {
1098             Lisp_Object arg = POP;
1099             TOP = Faref (TOP, arg);
1100             break;
1101           }
1102
1103         case Bmemq:
1104           {
1105             Lisp_Object arg = POP;
1106             TOP = Fmemq (TOP, arg);
1107             break;
1108           }
1109
1110         case Bset:
1111           {
1112             Lisp_Object arg = POP;
1113             TOP = Fset (TOP, arg);
1114             break;
1115           }
1116
1117         case Bequal:
1118           {
1119             Lisp_Object arg = POP;
1120             TOP = Fequal (TOP, arg);
1121             break;
1122           }
1123
1124         case Bnthcdr:
1125           {
1126             Lisp_Object arg = POP;
1127             TOP = Fnthcdr (TOP, arg);
1128             break;
1129           }
1130
1131         case Belt:
1132           {
1133             Lisp_Object arg = POP;
1134             TOP = Felt (TOP, arg);
1135             break;
1136           }
1137
1138         case Bmember:
1139           {
1140             Lisp_Object arg = POP;
1141             TOP = Fmember (TOP, arg);
1142             break;
1143           }
1144
1145         case Bgoto_char:
1146           TOP = Fgoto_char (TOP, Qnil);
1147           break;
1148
1149         case Bcurrent_buffer:
1150           {
1151             Lisp_Object buffer;
1152             XSETBUFFER (buffer, current_buffer);
1153             PUSH (buffer);
1154             break;
1155           }
1156
1157         case Bset_buffer:
1158           TOP = Fset_buffer (TOP);
1159           break;
1160
1161         case Bpoint_max:
1162           PUSH (make_int (BUF_ZV (current_buffer)));
1163           break;
1164
1165         case Bpoint_min:
1166           PUSH (make_int (BUF_BEGV (current_buffer)));
1167           break;
1168
1169         case Bskip_chars_forward:
1170           {
1171             Lisp_Object arg = POP;
1172             TOP = Fskip_chars_forward (TOP, arg, Qnil);
1173             break;
1174           }
1175
1176         case Bassq:
1177           {
1178             Lisp_Object arg = POP;
1179             TOP = Fassq (TOP, arg);
1180             break;
1181           }
1182
1183         case Bsetcar:
1184           {
1185             Lisp_Object arg = POP;
1186             TOP = Fsetcar (TOP, arg);
1187             break;
1188           }
1189
1190         case Bsetcdr:
1191           {
1192             Lisp_Object arg = POP;
1193             TOP = Fsetcdr (TOP, arg);
1194             break;
1195           }
1196
1197         case Bnreverse:
1198           TOP = bytecode_nreverse (TOP);
1199           break;
1200
1201         case Bcar_safe:
1202           TOP = CONSP (TOP) ? XCAR (TOP) : Qnil;
1203           break;
1204
1205         case Bcdr_safe:
1206           TOP = CONSP (TOP) ? XCDR (TOP) : Qnil;
1207           break;
1208
1209         }
1210     }
1211 }
1212
1213 /* It makes a worthwhile performance difference (5%) to shunt
1214    lesser-used opcodes off to a subroutine, to keep the switch in
1215    execute_optimized_program small.  If you REALLY care about
1216    performance, you want to keep your heavily executed code away from
1217    rarely executed code, to minimize cache misses.
1218
1219    Don't make this function static, since then the compiler might inline it. */
1220 Lisp_Object *
1221 execute_rare_opcode (Lisp_Object *stack_ptr,
1222                      const Opbyte *program_ptr,
1223                      Opcode opcode)
1224 {
1225   switch (opcode)
1226     {
1227
1228     case Bsave_excursion:
1229       record_unwind_protect (save_excursion_restore,
1230                              save_excursion_save ());
1231       break;
1232
1233     case Bsave_window_excursion:
1234       {
1235         int count = specpdl_depth ();
1236         record_unwind_protect (save_window_excursion_unwind,
1237                                Fcurrent_window_configuration (Qnil));
1238         TOP = Fprogn (TOP);
1239         unbind_to (count, Qnil);
1240         break;
1241       }
1242
1243     case Bsave_restriction:
1244       record_unwind_protect (save_restriction_restore,
1245                              save_restriction_save ());
1246       break;
1247
1248     case Bcatch:
1249       {
1250         Lisp_Object arg = POP;
1251         TOP = internal_catch (TOP, Feval, arg, 0);
1252         break;
1253       }
1254
1255     case Bskip_chars_backward:
1256       {
1257         Lisp_Object arg = POP;
1258         TOP = Fskip_chars_backward (TOP, arg, Qnil);
1259         break;
1260       }
1261
1262     case Bunwind_protect:
1263       record_unwind_protect (Fprogn, POP);
1264       break;
1265
1266     case Bcondition_case:
1267       {
1268         Lisp_Object arg2 = POP; /* handlers */
1269         Lisp_Object arg1 = POP; /* bodyform */
1270         TOP = condition_case_3 (arg1, TOP, arg2);
1271         break;
1272       }
1273
1274     case Bset_marker:
1275       {
1276         Lisp_Object arg2 = POP;
1277         Lisp_Object arg1 = POP;
1278         TOP = Fset_marker (TOP, arg1, arg2);
1279         break;
1280       }
1281
1282     case Brem:
1283       {
1284         Lisp_Object arg = POP;
1285         TOP = Frem (TOP, arg);
1286         break;
1287       }
1288
1289     case Bmatch_beginning:
1290       TOP = Fmatch_beginning (TOP);
1291       break;
1292
1293     case Bmatch_end:
1294       TOP = Fmatch_end (TOP);
1295       break;
1296
1297     case Bupcase:
1298       TOP = Fupcase (TOP, Qnil);
1299       break;
1300
1301     case Bdowncase:
1302       TOP = Fdowncase (TOP, Qnil);
1303       break;
1304
1305     case Bfset:
1306       {
1307         Lisp_Object arg = POP;
1308         TOP = Ffset (TOP, arg);
1309         break;
1310       }
1311
1312     case Bstring_equal:
1313       {
1314         Lisp_Object arg = POP;
1315         TOP = Fstring_equal (TOP, arg);
1316         break;
1317       }
1318
1319     case Bstring_lessp:
1320       {
1321         Lisp_Object arg = POP;
1322         TOP = Fstring_lessp (TOP, arg);
1323         break;
1324       }
1325
1326     case Bsubstring:
1327       {
1328         Lisp_Object arg2 = POP;
1329         Lisp_Object arg1 = POP;
1330         TOP = Fsubstring (TOP, arg1, arg2);
1331         break;
1332       }
1333
1334     case Bcurrent_column:
1335       PUSH (make_int (current_column (current_buffer)));
1336       break;
1337
1338     case Bchar_after:
1339       TOP = Fchar_after (TOP, Qnil);
1340       break;
1341
1342     case Bindent_to:
1343       TOP = Findent_to (TOP, Qnil, Qnil);
1344       break;
1345
1346     case Bwiden:
1347       PUSH (Fwiden (Qnil));
1348       break;
1349
1350     case Bfollowing_char:
1351       PUSH (Ffollowing_char (Qnil));
1352       break;
1353
1354     case Bpreceding_char:
1355       PUSH (Fpreceding_char (Qnil));
1356       break;
1357
1358     case Beolp:
1359       PUSH (Feolp (Qnil));
1360       break;
1361
1362     case Beobp:
1363       PUSH (Feobp (Qnil));
1364       break;
1365
1366     case Bbolp:
1367       PUSH (Fbolp (Qnil));
1368       break;
1369
1370     case Bbobp:
1371       PUSH (Fbobp (Qnil));
1372       break;
1373
1374     case Bsave_current_buffer:
1375       record_unwind_protect (save_current_buffer_restore,
1376                              Fcurrent_buffer ());
1377       break;
1378
1379     case Binteractive_p:
1380       PUSH (Finteractive_p ());
1381       break;
1382
1383     case Bforward_char:
1384       TOP = Fforward_char (TOP, Qnil);
1385       break;
1386
1387     case Bforward_word:
1388       TOP = Fforward_word (TOP, Qnil);
1389       break;
1390
1391     case Bforward_line:
1392       TOP = Fforward_line (TOP, Qnil);
1393       break;
1394
1395     case Bchar_syntax:
1396       TOP = Fchar_syntax (TOP, Qnil);
1397       break;
1398
1399     case Bbuffer_substring:
1400       {
1401         Lisp_Object arg = POP;
1402         TOP = Fbuffer_substring (TOP, arg, Qnil);
1403         break;
1404       }
1405
1406     case Bdelete_region:
1407       {
1408         Lisp_Object arg = POP;
1409         TOP = Fdelete_region (TOP, arg, Qnil);
1410         break;
1411       }
1412
1413     case Bnarrow_to_region:
1414       {
1415         Lisp_Object arg = POP;
1416         TOP = Fnarrow_to_region (TOP, arg, Qnil);
1417         break;
1418       }
1419
1420     case Bend_of_line:
1421       TOP = Fend_of_line (TOP, Qnil);
1422       break;
1423
1424     case Btemp_output_buffer_setup:
1425       temp_output_buffer_setup (TOP);
1426       TOP = Vstandard_output;
1427       break;
1428
1429     case Btemp_output_buffer_show:
1430       {
1431         Lisp_Object arg = POP;
1432         temp_output_buffer_show (TOP, Qnil);
1433         TOP = arg;
1434         /* GAG ME!! */
1435         /* pop binding of standard-output */
1436         unbind_to (specpdl_depth() - 1, Qnil);
1437         break;
1438       }
1439
1440     case Bold_eq:
1441       {
1442         Lisp_Object arg = POP;
1443         TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
1444         break;
1445       }
1446
1447     case Bold_memq:
1448       {
1449         Lisp_Object arg = POP;
1450         TOP = Fold_memq (TOP, arg);
1451         break;
1452       }
1453
1454     case Bold_equal:
1455       {
1456         Lisp_Object arg = POP;
1457         TOP = Fold_equal (TOP, arg);
1458         break;
1459       }
1460
1461     case Bold_member:
1462       {
1463         Lisp_Object arg = POP;
1464         TOP = Fold_member (TOP, arg);
1465         break;
1466       }
1467
1468     case Bold_assq:
1469       {
1470         Lisp_Object arg = POP;
1471         TOP = Fold_assq (TOP, arg);
1472         break;
1473       }
1474
1475     default:
1476       abort();
1477       break;
1478     }
1479   return stack_ptr;
1480 }
1481
1482 \f
1483 static void
1484 invalid_byte_code_error (char *error_message, ...)
1485 {
1486   Lisp_Object obj;
1487   va_list args;
1488   char *buf = alloca_array (char, strlen (error_message) + 128);
1489
1490   sprintf (buf, "%s", error_message);
1491   va_start (args, error_message);
1492   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (buf), Qnil, -1,
1493                                 args);
1494   va_end (args);
1495
1496   signal_error (Qinvalid_byte_code, list1 (obj));
1497 }
1498
1499 /* Check for valid opcodes.  Change this when adding new opcodes.  */
1500 static void
1501 check_opcode (Opcode opcode)
1502 {
1503   if ((opcode < Bvarref) ||
1504       (opcode == 0251)   ||
1505       (opcode > Bassq && opcode < Bconstant))
1506     invalid_byte_code_error
1507       ("invalid opcode %d in instruction stream", opcode);
1508 }
1509
1510 /* Check that IDX is a valid offset into the `constants' vector */
1511 static void
1512 check_constants_index (int idx, Lisp_Object constants)
1513 {
1514   if (idx < 0 || idx >= XVECTOR_LENGTH (constants))
1515     invalid_byte_code_error
1516       ("reference %d to constants array out of range 0, %d",
1517        idx, XVECTOR_LENGTH (constants) - 1);
1518 }
1519
1520 /* Get next character from Lisp instructions string. */
1521 #define READ_INSTRUCTION_CHAR(lvalue) do {              \
1522   (lvalue) = charptr_emchar (ptr);                      \
1523   INC_CHARPTR (ptr);                                    \
1524   *icounts_ptr++ = program_ptr - program;               \
1525   if (lvalue > UCHAR_MAX)                               \
1526     invalid_byte_code_error                             \
1527       ("Invalid character %c in byte code string");     \
1528 } while (0)
1529
1530 /* Get opcode from Lisp instructions string. */
1531 #define READ_OPCODE do {                \
1532   unsigned int c;                       \
1533   READ_INSTRUCTION_CHAR (c);            \
1534   opcode = (Opcode) c;                  \
1535 } while (0)
1536
1537 /* Get next operand, a uint8, from Lisp instructions string. */
1538 #define READ_OPERAND_1 do {             \
1539   READ_INSTRUCTION_CHAR (arg);          \
1540   argsize = 1;                          \
1541 } while (0)
1542
1543 /* Get next operand, a uint16, from Lisp instructions string. */
1544 #define READ_OPERAND_2 do {             \
1545   unsigned int arg1, arg2;              \
1546   READ_INSTRUCTION_CHAR (arg1);         \
1547   READ_INSTRUCTION_CHAR (arg2);         \
1548   arg = arg1 + (arg2 << 8);             \
1549   argsize = 2;                          \
1550 } while (0)
1551
1552 /* Write 1 byte to PTR, incrementing PTR */
1553 #define WRITE_INT8(value, ptr) do {     \
1554   *((ptr)++) = (value);                 \
1555 } while (0)
1556
1557 /* Write 2 bytes to PTR, incrementing PTR */
1558 #define WRITE_INT16(value, ptr) do {                    \
1559   WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr));    \
1560   WRITE_INT8 (((unsigned) (value)) >> 8    , (ptr));    \
1561 } while (0)
1562
1563 /* We've changed our minds about the opcode we've already written. */
1564 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
1565
1566 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
1567 #define WRITE_NARGS(base_opcode) do {           \
1568   if (arg <= 5)                                 \
1569     {                                           \
1570       REWRITE_OPCODE (base_opcode + arg);       \
1571     }                                           \
1572   else if (arg <= UCHAR_MAX)                    \
1573     {                                           \
1574       REWRITE_OPCODE (base_opcode + 6);         \
1575       WRITE_INT8 (arg, program_ptr);            \
1576     }                                           \
1577   else                                          \
1578     {                                           \
1579       REWRITE_OPCODE (base_opcode + 7);         \
1580       WRITE_INT16 (arg, program_ptr);           \
1581     }                                           \
1582 } while (0)
1583
1584 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
1585 #define WRITE_CONSTANT do {                     \
1586   check_constants_index(arg, constants);        \
1587   if (arg <= UCHAR_MAX - Bconstant)             \
1588     {                                           \
1589       REWRITE_OPCODE (Bconstant + arg);         \
1590     }                                           \
1591   else                                          \
1592     {                                           \
1593       REWRITE_OPCODE (Bconstant2);              \
1594       WRITE_INT16 (arg, program_ptr);           \
1595     }                                           \
1596 } while (0)
1597
1598 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
1599
1600 /* Compile byte code instructions into free space provided by caller, with
1601    size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
1602    Returns length of compiled code. */
1603 static void
1604 optimize_byte_code (/* in */
1605                     Lisp_Object instructions,
1606                     Lisp_Object constants,
1607                     /* out */
1608                     Opbyte * const program,
1609                     int * const program_length,
1610                     int * const varbind_count)
1611 {
1612   size_t instructions_length = XSTRING_LENGTH (instructions);
1613   size_t comfy_size = 2 * instructions_length;
1614
1615   int * const icounts = alloca_array (int, comfy_size);
1616   int * icounts_ptr = icounts;
1617
1618   /* We maintain a table of jumps in the source code. */
1619   struct jump
1620   {
1621     int from;
1622     int to;
1623   };
1624   struct jump * const jumps = alloca_array (struct jump, comfy_size);
1625   struct jump *jumps_ptr = jumps;
1626
1627   Opbyte *program_ptr = program;
1628
1629   const Bufbyte *ptr = XSTRING_DATA (instructions);
1630   const Bufbyte * const end = ptr + instructions_length;
1631
1632   *varbind_count = 0;
1633
1634   while (ptr < end)
1635     {
1636       Opcode opcode;
1637       int arg;
1638       int argsize = 0;
1639       READ_OPCODE;
1640       WRITE_OPCODE;
1641
1642       switch (opcode)
1643         {
1644           Lisp_Object val;
1645
1646         case Bvarref+7: READ_OPERAND_2; goto do_varref;
1647         case Bvarref+6: READ_OPERAND_1; goto do_varref;
1648         case Bvarref:   case Bvarref+1: case Bvarref+2:
1649         case Bvarref+3: case Bvarref+4: case Bvarref+5:
1650           arg = opcode - Bvarref;
1651         do_varref:
1652           check_constants_index (arg, constants);
1653            val = XVECTOR_DATA (constants) [arg];
1654            if (!SYMBOLP (val))
1655              invalid_byte_code_error ("variable reference to non-symbol %S", val);
1656            if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1657              invalid_byte_code_error ("variable reference to constant symbol %s",
1658                                       string_data (XSYMBOL (val)->name));
1659            WRITE_NARGS (Bvarref);
1660            break;
1661
1662         case Bvarset+7: READ_OPERAND_2; goto do_varset;
1663         case Bvarset+6: READ_OPERAND_1; goto do_varset;
1664         case Bvarset:   case Bvarset+1: case Bvarset+2:
1665         case Bvarset+3: case Bvarset+4: case Bvarset+5:
1666           arg = opcode - Bvarset;
1667         do_varset:
1668           check_constants_index (arg, constants);
1669           val = XVECTOR_DATA (constants) [arg];
1670           if (!SYMBOLP (val))
1671             invalid_byte_code_error ("attempt to set non-symbol %S", val);
1672           if (EQ (val, Qnil) || EQ (val, Qt))
1673             invalid_byte_code_error ("attempt to set constant symbol %s",
1674                                      string_data (XSYMBOL (val)->name));
1675           /* Ignore assignments to keywords by converting to Bdiscard.
1676              For backward compatibility only - we'd like to make this an error.  */
1677           if (SYMBOL_IS_KEYWORD (val))
1678             REWRITE_OPCODE (Bdiscard);
1679           else
1680             WRITE_NARGS (Bvarset);
1681           break;
1682
1683         case Bvarbind+7: READ_OPERAND_2; goto do_varbind;
1684         case Bvarbind+6: READ_OPERAND_1; goto do_varbind;
1685         case Bvarbind:   case Bvarbind+1: case Bvarbind+2:
1686         case Bvarbind+3: case Bvarbind+4: case Bvarbind+5:
1687           arg = opcode - Bvarbind;
1688         do_varbind:
1689           (*varbind_count)++;
1690           check_constants_index (arg, constants);
1691           val = XVECTOR_DATA (constants) [arg];
1692           if (!SYMBOLP (val))
1693             invalid_byte_code_error ("attempt to let-bind non-symbol %S", val);
1694           if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1695             invalid_byte_code_error ("attempt to let-bind constant symbol %s",
1696                                      string_data (XSYMBOL (val)->name));
1697           WRITE_NARGS (Bvarbind);
1698           break;
1699
1700         case Bcall+7: READ_OPERAND_2; goto do_call;
1701         case Bcall+6: READ_OPERAND_1; goto do_call;
1702         case Bcall:   case Bcall+1: case Bcall+2:
1703         case Bcall+3: case Bcall+4: case Bcall+5:
1704           arg = opcode - Bcall;
1705         do_call:
1706           WRITE_NARGS (Bcall);
1707           break;
1708
1709         case Bunbind+7: READ_OPERAND_2; goto do_unbind;
1710         case Bunbind+6: READ_OPERAND_1; goto do_unbind;
1711         case Bunbind:   case Bunbind+1: case Bunbind+2:
1712         case Bunbind+3: case Bunbind+4: case Bunbind+5:
1713           arg = opcode - Bunbind;
1714         do_unbind:
1715           WRITE_NARGS (Bunbind);
1716           break;
1717
1718         case Bgoto:
1719         case Bgotoifnil:
1720         case Bgotoifnonnil:
1721         case Bgotoifnilelsepop:
1722         case Bgotoifnonnilelsepop:
1723           READ_OPERAND_2;
1724           /* Make program_ptr-relative */
1725           arg += icounts - (icounts_ptr - argsize);
1726           goto do_jump;
1727
1728         case BRgoto:
1729         case BRgotoifnil:
1730         case BRgotoifnonnil:
1731         case BRgotoifnilelsepop:
1732         case BRgotoifnonnilelsepop:
1733           READ_OPERAND_1;
1734           /* Make program_ptr-relative */
1735           arg -= 127;
1736         do_jump:
1737           /* Record program-relative goto addresses in `jumps' table */
1738           jumps_ptr->from = icounts_ptr - icounts - argsize;
1739           jumps_ptr->to   = jumps_ptr->from + arg;
1740           jumps_ptr++;
1741           if (arg >= -1 && arg <= argsize)
1742             invalid_byte_code_error
1743               ("goto instruction is its own target");
1744           if (arg <= SCHAR_MIN ||
1745               arg >  SCHAR_MAX)
1746             {
1747               if (argsize == 1)
1748                 REWRITE_OPCODE (opcode + Bgoto - BRgoto);
1749               WRITE_INT16 (arg, program_ptr);
1750             }
1751           else
1752             {
1753               if (argsize == 2)
1754                 REWRITE_OPCODE (opcode + BRgoto - Bgoto);
1755               WRITE_INT8 (arg, program_ptr);
1756             }
1757           break;
1758
1759         case Bconstant2:
1760           READ_OPERAND_2;
1761           WRITE_CONSTANT;
1762           break;
1763
1764         case BlistN:
1765         case BconcatN:
1766         case BinsertN:
1767           READ_OPERAND_1;
1768           WRITE_INT8 (arg, program_ptr);
1769           break;
1770
1771         default:
1772           if (opcode < Bconstant)
1773             check_opcode (opcode);
1774           else
1775             {
1776               arg = opcode - Bconstant;
1777               WRITE_CONSTANT;
1778             }
1779           break;
1780         }
1781     }
1782
1783   /* Fix up jumps table to refer to NEW offsets. */
1784   {
1785     struct jump *j;
1786     for (j = jumps; j < jumps_ptr; j++)
1787       {
1788 #ifdef ERROR_CHECK_BYTE_CODE
1789         assert (j->from < icounts_ptr - icounts);
1790         assert (j->to   < icounts_ptr - icounts);
1791 #endif
1792         j->from = icounts[j->from];
1793         j->to   = icounts[j->to];
1794 #ifdef ERROR_CHECK_BYTE_CODE
1795         assert (j->from < program_ptr - program);
1796         assert (j->to   < program_ptr - program);
1797         check_opcode ((Opcode) (program[j->from-1]));
1798 #endif
1799         check_opcode ((Opcode) (program[j->to]));
1800       }
1801   }
1802
1803   /* Fixup jumps in byte-code until no more fixups needed */
1804   {
1805     int more_fixups_needed = 1;
1806
1807     while (more_fixups_needed)
1808       {
1809         struct jump *j;
1810         more_fixups_needed = 0;
1811         for (j = jumps; j < jumps_ptr; j++)
1812         {
1813           int from = j->from;
1814           int to   = j->to;
1815           int jump = to - from;
1816           Opbyte *p = program + from;
1817           Opcode opcode = (Opcode) p[-1];
1818           if (!more_fixups_needed)
1819             check_opcode ((Opcode) p[jump]);
1820           assert (to >= 0 && program + to < program_ptr);
1821           switch (opcode)
1822             {
1823               case Bgoto:
1824               case Bgotoifnil:
1825               case Bgotoifnonnil:
1826               case Bgotoifnilelsepop:
1827               case Bgotoifnonnilelsepop:
1828                 WRITE_INT16 (jump, p);
1829                 break;
1830
1831               case BRgoto:
1832               case BRgotoifnil:
1833               case BRgotoifnonnil:
1834               case BRgotoifnilelsepop:
1835               case BRgotoifnonnilelsepop:
1836                 if (jump >  SCHAR_MIN &&
1837                     jump <= SCHAR_MAX)
1838                   {
1839                     WRITE_INT8 (jump, p);
1840                   }
1841                 else            /* barf */
1842                   {
1843                     struct jump *jj;
1844                     for (jj = jumps; jj < jumps_ptr; jj++)
1845                       {
1846                         assert (jj->from < program_ptr - program);
1847                         assert (jj->to   < program_ptr - program);
1848                         if (jj->from > from) jj->from++;
1849                         if (jj->to   > from) jj->to++;
1850                       }
1851                     p[-1] += Bgoto - BRgoto;
1852                     more_fixups_needed = 1;
1853                     memmove (p+1, p, program_ptr++ - p);
1854                     WRITE_INT16 (jump, p);
1855                   }
1856                 break;
1857
1858             default:
1859               abort();
1860               break;
1861             }
1862         }
1863       }
1864   }
1865
1866   /* *program_ptr++ = 0; */
1867   *program_length = program_ptr - program;
1868 }
1869
1870 /* Optimize the byte code and store the optimized program, only
1871    understood by bytecode.c, in an opaque object in the
1872    instructions slot of the Compiled_Function object. */
1873 void
1874 optimize_compiled_function (Lisp_Object compiled_function)
1875 {
1876   Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
1877   int program_length;
1878   int varbind_count;
1879   Opbyte *program;
1880
1881   /* If we have not actually read the bytecode string
1882      and constants vector yet, fetch them from the file.  */
1883   if (CONSP (f->instructions))
1884     Ffetch_bytecode (compiled_function);
1885
1886   if (STRINGP (f->instructions))
1887     {
1888       /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
1889          which would be slightly more `proper' */
1890       program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
1891       optimize_byte_code (f->instructions, f->constants,
1892                           program, &program_length, &varbind_count);
1893       f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count;
1894       f->instructions =
1895         make_opaque (program, program_length * sizeof (Opbyte));
1896     }
1897
1898   assert (OPAQUEP (f->instructions));
1899 }
1900 \f
1901 /************************************************************************/
1902 /*              The compiled-function object type                       */
1903 /************************************************************************/
1904 static void
1905 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
1906                          int escapeflag)
1907 {
1908   /* This function can GC */
1909   Lisp_Compiled_Function *f =
1910     XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
1911   int docp = f->flags.documentationp;
1912   int intp = f->flags.interactivep;
1913   struct gcpro gcpro1, gcpro2;
1914   char buf[100];
1915   GCPRO2 (obj, printcharfun);
1916
1917   write_c_string (print_readably ? "#[" : "#<compiled-function ", printcharfun);
1918 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1919   if (!print_readably)
1920     {
1921       Lisp_Object ann = compiled_function_annotation (f);
1922       if (!NILP (ann))
1923         {
1924           write_c_string ("(from ", printcharfun);
1925           print_internal (ann, printcharfun, 1);
1926           write_c_string (") ", printcharfun);
1927         }
1928     }
1929 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1930   /* COMPILED_ARGLIST = 0 */
1931   print_internal (compiled_function_arglist (f), printcharfun, escapeflag);
1932
1933   /* COMPILED_INSTRUCTIONS = 1 */
1934   write_c_string (" ", printcharfun);
1935   {
1936     struct gcpro ngcpro1;
1937     Lisp_Object instructions = compiled_function_instructions (f);
1938     NGCPRO1 (instructions);
1939     if (STRINGP (instructions) && !print_readably)
1940       {
1941         /* We don't usually want to see that junk in the bytecode. */
1942         sprintf (buf, "\"...(%ld)\"",
1943                  (long) XSTRING_CHAR_LENGTH (instructions));
1944         write_c_string (buf, printcharfun);
1945       }
1946     else
1947       print_internal (instructions, printcharfun, escapeflag);
1948     NUNGCPRO;
1949   }
1950
1951   /* COMPILED_CONSTANTS = 2 */
1952   write_c_string (" ", printcharfun);
1953   print_internal (compiled_function_constants (f), printcharfun, escapeflag);
1954
1955   /* COMPILED_STACK_DEPTH = 3 */
1956   sprintf (buf, " %d", compiled_function_stack_depth (f));
1957   write_c_string (buf, printcharfun);
1958
1959   /* COMPILED_DOC_STRING = 4 */
1960   if (docp || intp)
1961     {
1962       write_c_string (" ", printcharfun);
1963       print_internal (compiled_function_documentation (f), printcharfun,
1964                       escapeflag);
1965     }
1966
1967   /* COMPILED_INTERACTIVE = 5 */
1968   if (intp)
1969     {
1970       write_c_string (" ", printcharfun);
1971       print_internal (compiled_function_interactive (f), printcharfun,
1972                       escapeflag);
1973     }
1974
1975   UNGCPRO;
1976   write_c_string (print_readably ? "]" : ">", printcharfun);
1977 }
1978
1979
1980 static Lisp_Object
1981 mark_compiled_function (Lisp_Object obj)
1982 {
1983   Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
1984
1985   mark_object (f->instructions);
1986   mark_object (f->arglist);
1987   mark_object (f->doc_and_interactive);
1988 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1989   mark_object (f->annotated);
1990 #endif
1991   /* tail-recurse on constants */
1992   return f->constants;
1993 }
1994
1995 static int
1996 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1997 {
1998   Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1);
1999   Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2);
2000   return
2001     (f1->flags.documentationp == f2->flags.documentationp &&
2002      f1->flags.interactivep   == f2->flags.interactivep   &&
2003      f1->flags.domainp        == f2->flags.domainp        && /* I18N3 */
2004      internal_equal (compiled_function_instructions (f1),
2005                      compiled_function_instructions (f2), depth + 1) &&
2006      internal_equal (f1->constants,    f2->constants,    depth + 1) &&
2007      internal_equal (f1->arglist,      f2->arglist,      depth + 1) &&
2008      internal_equal (f1->doc_and_interactive,
2009                      f2->doc_and_interactive, depth + 1));
2010 }
2011
2012 static unsigned long
2013 compiled_function_hash (Lisp_Object obj, int depth)
2014 {
2015   Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
2016   return HASH3 ((f->flags.documentationp << 2) +
2017                 (f->flags.interactivep << 1) +
2018                 f->flags.domainp,
2019                 internal_hash (f->instructions, depth + 1),
2020                 internal_hash (f->constants,    depth + 1));
2021 }
2022
2023 static const struct lrecord_description compiled_function_description[] = {
2024   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) },
2025   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) },
2026   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) },
2027   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) },
2028 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2029   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) },
2030 #endif
2031   { XD_END }
2032 };
2033
2034 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
2035                                      mark_compiled_function,
2036                                      print_compiled_function, 0,
2037                                      compiled_function_equal,
2038                                      compiled_function_hash,
2039                                      compiled_function_description,
2040                                      Lisp_Compiled_Function);
2041 \f
2042 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
2043 Return t if OBJECT is a byte-compiled function object.
2044 */
2045        (object))
2046 {
2047   return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
2048 }
2049
2050 /************************************************************************/
2051 /*              compiled-function object accessor functions             */
2052 /************************************************************************/
2053
2054 Lisp_Object
2055 compiled_function_arglist (Lisp_Compiled_Function *f)
2056 {
2057   return f->arglist;
2058 }
2059
2060 Lisp_Object
2061 compiled_function_instructions (Lisp_Compiled_Function *f)
2062 {
2063   if (! OPAQUEP (f->instructions))
2064     return f->instructions;
2065
2066   {
2067     /* Invert action performed by optimize_byte_code() */
2068     Lisp_Opaque *opaque = XOPAQUE (f->instructions);
2069
2070     Bufbyte * const buffer =
2071       alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
2072     Bufbyte *bp = buffer;
2073
2074     const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque);
2075     const Opbyte *program_ptr = program;
2076     const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque);
2077
2078     while (program_ptr < program_end)
2079       {
2080         Opcode opcode = (Opcode) READ_UINT_1;
2081         bp += set_charptr_emchar (bp, opcode);
2082         switch (opcode)
2083           {
2084           case Bvarref+7:
2085           case Bvarset+7:
2086           case Bvarbind+7:
2087           case Bcall+7:
2088           case Bunbind+7:
2089           case Bconstant2:
2090             bp += set_charptr_emchar (bp, READ_UINT_1);
2091             bp += set_charptr_emchar (bp, READ_UINT_1);
2092             break;
2093
2094           case Bvarref+6:
2095           case Bvarset+6:
2096           case Bvarbind+6:
2097           case Bcall+6:
2098           case Bunbind+6:
2099           case BlistN:
2100           case BconcatN:
2101           case BinsertN:
2102             bp += set_charptr_emchar (bp, READ_UINT_1);
2103             break;
2104
2105           case Bgoto:
2106           case Bgotoifnil:
2107           case Bgotoifnonnil:
2108           case Bgotoifnilelsepop:
2109           case Bgotoifnonnilelsepop:
2110             {
2111               int jump = READ_INT_2;
2112               Opbyte buf2[2];
2113               Opbyte *buf2p = buf2;
2114               /* Convert back to program-relative address */
2115               WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p);
2116               bp += set_charptr_emchar (bp, buf2[0]);
2117               bp += set_charptr_emchar (bp, buf2[1]);
2118               break;
2119             }
2120
2121           case BRgoto:
2122           case BRgotoifnil:
2123           case BRgotoifnonnil:
2124           case BRgotoifnilelsepop:
2125           case BRgotoifnonnilelsepop:
2126             bp += set_charptr_emchar (bp, READ_INT_1 + 127);
2127             break;
2128
2129           default:
2130             break;
2131           }
2132       }
2133     return make_string (buffer, bp - buffer);
2134   }
2135 }
2136
2137 Lisp_Object
2138 compiled_function_constants (Lisp_Compiled_Function *f)
2139 {
2140   return f->constants;
2141 }
2142
2143 int
2144 compiled_function_stack_depth (Lisp_Compiled_Function *f)
2145 {
2146   return f->stack_depth;
2147 }
2148
2149 /* The compiled_function->doc_and_interactive slot uses the minimal
2150    number of conses, based on compiled_function->flags; it may take
2151    any of the following forms:
2152
2153         doc
2154         interactive
2155         domain
2156         (doc . interactive)
2157         (doc . domain)
2158         (interactive . domain)
2159         (doc . (interactive . domain))
2160  */
2161
2162 /* Caller must check flags.interactivep first */
2163 Lisp_Object
2164 compiled_function_interactive (Lisp_Compiled_Function *f)
2165 {
2166   assert (f->flags.interactivep);
2167   if (f->flags.documentationp && f->flags.domainp)
2168     return XCAR (XCDR (f->doc_and_interactive));
2169   else if (f->flags.documentationp)
2170     return XCDR (f->doc_and_interactive);
2171   else if (f->flags.domainp)
2172     return XCAR (f->doc_and_interactive);
2173   else
2174     return f->doc_and_interactive;
2175 }
2176
2177 /* Caller need not check flags.documentationp first */
2178 Lisp_Object
2179 compiled_function_documentation (Lisp_Compiled_Function *f)
2180 {
2181   if (! f->flags.documentationp)
2182     return Qnil;
2183   else if (f->flags.interactivep && f->flags.domainp)
2184     return XCAR (f->doc_and_interactive);
2185   else if (f->flags.interactivep)
2186     return XCAR (f->doc_and_interactive);
2187   else if (f->flags.domainp)
2188     return XCAR (f->doc_and_interactive);
2189   else
2190     return f->doc_and_interactive;
2191 }
2192
2193 /* Caller need not check flags.domainp first */
2194 Lisp_Object
2195 compiled_function_domain (Lisp_Compiled_Function *f)
2196 {
2197   if (! f->flags.domainp)
2198     return Qnil;
2199   else if (f->flags.documentationp && f->flags.interactivep)
2200     return XCDR (XCDR (f->doc_and_interactive));
2201   else if (f->flags.documentationp)
2202     return XCDR (f->doc_and_interactive);
2203   else if (f->flags.interactivep)
2204     return XCDR (f->doc_and_interactive);
2205   else
2206     return f->doc_and_interactive;
2207 }
2208
2209 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2210
2211 Lisp_Object
2212 compiled_function_annotation (Lisp_Compiled_Function *f)
2213 {
2214   return f->annotated;
2215 }
2216
2217 #endif
2218
2219 /* used only by Snarf-documentation; there must be doc already. */
2220 void
2221 set_compiled_function_documentation (Lisp_Compiled_Function *f,
2222                                      Lisp_Object new_doc)
2223 {
2224   assert (f->flags.documentationp);
2225   assert (INTP (new_doc) || STRINGP (new_doc));
2226
2227   if (f->flags.interactivep && f->flags.domainp)
2228     XCAR (f->doc_and_interactive) = new_doc;
2229   else if (f->flags.interactivep)
2230     XCAR (f->doc_and_interactive) = new_doc;
2231   else if (f->flags.domainp)
2232     XCAR (f->doc_and_interactive) = new_doc;
2233   else
2234     f->doc_and_interactive = new_doc;
2235 }
2236
2237
2238 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2239 Return the argument list of the compiled-function object FUNCTION.
2240 */
2241        (function))
2242 {
2243   CHECK_COMPILED_FUNCTION (function);
2244   return compiled_function_arglist (XCOMPILED_FUNCTION (function));
2245 }
2246
2247 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
2248 Return the byte-opcode string of the compiled-function object FUNCTION.
2249 */
2250        (function))
2251 {
2252   CHECK_COMPILED_FUNCTION (function);
2253   return compiled_function_instructions (XCOMPILED_FUNCTION (function));
2254 }
2255
2256 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
2257 Return the constants vector of the compiled-function object FUNCTION.
2258 */
2259        (function))
2260 {
2261   CHECK_COMPILED_FUNCTION (function);
2262   return compiled_function_constants (XCOMPILED_FUNCTION (function));
2263 }
2264
2265 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2266 Return the max stack depth of the compiled-function object FUNCTION.
2267 */
2268        (function))
2269 {
2270   CHECK_COMPILED_FUNCTION (function);
2271   return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function)));
2272 }
2273
2274 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
2275 Return the doc string of the compiled-function object FUNCTION, if available.
2276 Functions that had their doc strings snarfed into the DOC file will have
2277 an integer returned instead of a string.
2278 */
2279        (function))
2280 {
2281   CHECK_COMPILED_FUNCTION (function);
2282   return compiled_function_documentation (XCOMPILED_FUNCTION (function));
2283 }
2284
2285 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2286 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2287 If non-nil, the return value will be a list whose first element is
2288 `interactive' and whose second element is the interactive spec.
2289 */
2290        (function))
2291 {
2292   CHECK_COMPILED_FUNCTION (function);
2293   return XCOMPILED_FUNCTION (function)->flags.interactivep
2294     ? list2 (Qinteractive,
2295              compiled_function_interactive (XCOMPILED_FUNCTION (function)))
2296     : Qnil;
2297 }
2298
2299 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2300
2301 /* Remove the `xx' if you wish to restore this feature */
2302 xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2303 Return the annotation of the compiled-function object FUNCTION, or nil.
2304 The annotation is a piece of information indicating where this
2305 compiled-function object came from.  Generally this will be
2306 a symbol naming a function; or a string naming a file, if the
2307 compiled-function object was not defined in a function; or nil,
2308 if the compiled-function object was not created as a result of
2309 a `load'.
2310 */
2311        (function))
2312 {
2313   CHECK_COMPILED_FUNCTION (function);
2314   return compiled_function_annotation (XCOMPILED_FUNCTION (function));
2315 }
2316
2317 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2318
2319 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
2320 Return the domain of the compiled-function object FUNCTION, or nil.
2321 This is only meaningful if I18N3 was enabled when emacs was compiled.
2322 */
2323        (function))
2324 {
2325   CHECK_COMPILED_FUNCTION (function);
2326   return XCOMPILED_FUNCTION (function)->flags.domainp
2327     ? compiled_function_domain (XCOMPILED_FUNCTION (function))
2328     : Qnil;
2329 }
2330
2331 \f
2332
2333 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
2334 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2335 */
2336        (function))
2337 {
2338   Lisp_Compiled_Function *f;
2339   CHECK_COMPILED_FUNCTION (function);
2340   f = XCOMPILED_FUNCTION (function);
2341
2342   if (OPAQUEP (f->instructions) || STRINGP (f->instructions))
2343     return function;
2344
2345   if (CONSP (f->instructions))
2346     {
2347       Lisp_Object tem = read_doc_string (f->instructions);
2348       if (!CONSP (tem))
2349         signal_simple_error ("Invalid lazy-loaded byte code", tem);
2350       /* v18 or v19 bytecode file.  Need to Ebolify. */
2351       if (f->flags.ebolified && VECTORP (XCDR (tem)))
2352         ebolify_bytecode_constants (XCDR (tem));
2353       f->instructions = XCAR (tem);
2354       f->constants    = XCDR (tem);
2355       return function;
2356     }
2357   abort ();
2358   return Qnil; /* not reached */
2359 }
2360
2361 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
2362 Convert compiled function FUNCTION into an optimized internal form.
2363 */
2364        (function))
2365 {
2366   Lisp_Compiled_Function *f;
2367   CHECK_COMPILED_FUNCTION (function);
2368   f = XCOMPILED_FUNCTION (function);
2369
2370   if (OPAQUEP (f->instructions)) /* Already optimized? */
2371     return Qnil;
2372
2373   optimize_compiled_function (function);
2374   return Qnil;
2375 }
2376
2377 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /*
2378 Function used internally in byte-compiled code.
2379 First argument INSTRUCTIONS is a string of byte code.
2380 Second argument CONSTANTS is a vector of constants.
2381 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2382 If STACK-DEPTH is incorrect, Emacs may crash.
2383 */
2384        (instructions, constants, stack_depth))
2385 {
2386   /* This function can GC */
2387   int varbind_count;
2388   int program_length;
2389   Opbyte *program;
2390
2391   CHECK_STRING (instructions);
2392   CHECK_VECTOR (constants);
2393   CHECK_NATNUM (stack_depth);
2394
2395   /* Optimize the `instructions' string, just like when executing a
2396      regular compiled function, but don't save it for later since this is
2397      likely to only be executed once. */
2398   program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
2399   optimize_byte_code (instructions, constants, program,
2400                       &program_length, &varbind_count);
2401   SPECPDL_RESERVE (varbind_count);
2402   return execute_optimized_program (program,
2403                                     XINT (stack_depth),
2404                                     XVECTOR_DATA (constants));
2405 }
2406
2407 \f
2408 void
2409 syms_of_bytecode (void)
2410 {
2411   INIT_LRECORD_IMPLEMENTATION (compiled_function);
2412
2413   deferror (&Qinvalid_byte_code, "invalid-byte-code",
2414             "Invalid byte code", Qerror);
2415   defsymbol (&Qbyte_code, "byte-code");
2416   defsymbol (&Qcompiled_functionp, "compiled-function-p");
2417
2418   DEFSUBR (Fbyte_code);
2419   DEFSUBR (Ffetch_bytecode);
2420   DEFSUBR (Foptimize_compiled_function);
2421
2422   DEFSUBR (Fcompiled_function_p);
2423   DEFSUBR (Fcompiled_function_instructions);
2424   DEFSUBR (Fcompiled_function_constants);
2425   DEFSUBR (Fcompiled_function_stack_depth);
2426   DEFSUBR (Fcompiled_function_arglist);
2427   DEFSUBR (Fcompiled_function_interactive);
2428   DEFSUBR (Fcompiled_function_doc_string);
2429   DEFSUBR (Fcompiled_function_domain);
2430 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2431   DEFSUBR (Fcompiled_function_annotation);
2432 #endif
2433
2434 #ifdef BYTE_CODE_METER
2435   defsymbol (&Qbyte_code_meter, "byte-code-meter");
2436 #endif
2437 }
2438
2439 void
2440 vars_of_bytecode (void)
2441 {
2442 #ifdef BYTE_CODE_METER
2443
2444   DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
2445 A vector of vectors which holds a histogram of byte code usage.
2446 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2447 opcode CODE has been executed.
2448 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2449 indicates how many times the byte opcodes CODE1 and CODE2 have been
2450 executed in succession.
2451 */ );
2452   DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /*
2453 If non-nil, keep profiling information on byte code usage.
2454 The variable `byte-code-meter' indicates how often each byte opcode is used.
2455 If a symbol has a property named `byte-code-meter' whose value is an
2456 integer, it is incremented each time that symbol's function is called.
2457 */ );
2458
2459   byte_metering_on = 0;
2460   Vbyte_code_meter = make_vector (256, Qzero);
2461   {
2462     int i = 256;
2463     while (i--)
2464       XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero);
2465   }
2466 #endif /* BYTE_CODE_METER */
2467 }