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