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 check_opcode (Opcode opcode);
 215 static void invalid_byte_code_error (char *error_message, ...);
 216
 217 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
 218                                    const Opbyte *program_ptr,
 219                                    Opcode opcode);
 220
 221 static Lisp_Object execute_optimized_program (const Opbyte *program,
 222                                               int stack_depth,
 223                                               Lisp_Object *constants_data);
 224
 225 extern Lisp_Object Qand_rest, Qand_optional;
 226
 227 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
 228    This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
 229 /* #define BYTE_CODE_METER */
 230
 231 \f
 232 #ifdef BYTE_CODE_METER
 233
 234 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
 235 int byte_metering_on;
 236
 237 static void
 238 meter_code (Opcode prev_opcode, Opcode this_opcode)
 239 {
 240   if (byte_metering_on)
 241     {
 242       Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]);
 243       p[0] = INT_PLUS1 (p[0]);
 244       if (prev_opcode)
 245         p[prev_opcode] = INT_PLUS1 (p[prev_opcode]);
 246     }
 247 }
 248
 249 #endif /* BYTE_CODE_METER */
 250
 251 \f
 252 static Lisp_Object
 253 bytecode_negate (Lisp_Object obj)
 254 {
 255  retry:
 256
 257   if (INTP    (obj)) return make_int (- XINT (obj));
 258 #ifdef LISP_FLOAT_TYPE
 259   if (FLOATP  (obj)) return make_float (- XFLOAT_DATA (obj));
 260 #endif
 261   if (CHARP   (obj)) return make_int (- ((int) XCHAR (obj)));
 262   if (MARKERP (obj)) return make_int (- ((int) marker_position (obj)));
 263
 264   obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
 265   goto retry;
 266 }
 267
 268 static Lisp_Object
 269 bytecode_nreverse (Lisp_Object list)
 270 {
 271   REGISTER Lisp_Object prev = Qnil;
 272   REGISTER Lisp_Object tail = list;
 273
 274   while (!NILP (tail))
 275     {
 276       REGISTER Lisp_Object next;
 277       CHECK_CONS (tail);
 278       next = XCDR (tail);
 279       XCDR (tail) = prev;
 280       prev = tail;
 281       tail = next;
 282     }
 283   return prev;
 284 }
 285
 286
 287 /* We have our own two-argument versions of various arithmetic ops.
 288    Only two-argument arithmetic operations have their own byte codes. */
 289 static int
 290 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2)
 291 {
 292   retry:
 293
 294 #ifdef LISP_FLOAT_TYPE
 295   {
 296     EMACS_INT ival1, ival2;
 297
 298     if      (INTP    (obj1)) ival1 = XINT  (obj1);
 299     else if (CHARP   (obj1)) ival1 = XCHAR (obj1);
 300     else if (MARKERP (obj1)) ival1 = marker_position (obj1);
 301     else goto arithcompare_float;
 302
 303     if      (INTP    (obj2)) ival2 = XINT  (obj2);
 304     else if (CHARP   (obj2)) ival2 = XCHAR (obj2);
 305     else if (MARKERP (obj2)) ival2 = marker_position (obj2);
 306     else goto arithcompare_float;
 307
 308     return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
 309   }
 310
 311  arithcompare_float:
 312
 313   {
 314     double dval1, dval2;
 315
 316     if      (FLOATP  (obj1)) dval1 = XFLOAT_DATA (obj1);
 317     else if (INTP    (obj1)) dval1 = (double) XINT  (obj1);
 318     else if (CHARP   (obj1)) dval1 = (double) XCHAR (obj1);
 319     else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1);
 320     else
 321       {
 322         obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
 323         goto retry;
 324       }
 325
 326     if      (FLOATP  (obj2)) dval2 = XFLOAT_DATA (obj2);
 327     else if (INTP    (obj2)) dval2 = (double) XINT  (obj2);
 328     else if (CHARP   (obj2)) dval2 = (double) XCHAR (obj2);
 329     else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2);
 330     else
 331       {
 332         obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
 333         goto retry;
 334       }
 335
 336     return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
 337   }
 338 #else /* !LISP_FLOAT_TYPE */
 339   {
 340     EMACS_INT ival1, ival2;
 341
 342     if      (INTP    (obj1)) ival1 = XINT  (obj1);
 343     else if (CHARP   (obj1)) ival1 = XCHAR (obj1);
 344     else if (MARKERP (obj1)) ival1 = marker_position (obj1);
 345     else
 346       {
 347         obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
 348         goto retry;
 349       }
 350
 351     if      (INTP    (obj2)) ival2 = XINT  (obj2);
 352     else if (CHARP   (obj2)) ival2 = XCHAR (obj2);
 353     else if (MARKERP (obj2)) ival2 = marker_position (obj2);
 354     else
 355       {
 356         obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
 357         goto retry;
 358       }
 359
 360     return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
 361   }
 362 #endif /* !LISP_FLOAT_TYPE */
 363 }
 364
 365 static Lisp_Object
 366 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
 367 {
 368 #ifdef LISP_FLOAT_TYPE
 369   EMACS_INT ival1, ival2;
 370   int float_p;
 371
 372  retry:
 373
 374   float_p = 0;
 375
 376   if      (INTP    (obj1)) ival1 = XINT  (obj1);
 377   else if (CHARP   (obj1)) ival1 = XCHAR (obj1);
 378   else if (MARKERP (obj1)) ival1 = marker_position (obj1);
 379   else if (FLOATP  (obj1)) ival1 = 0, float_p = 1;
 380   else
 381     {
 382       obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
 383       goto retry;
 384     }
 385
 386   if      (INTP    (obj2)) ival2 = XINT  (obj2);
 387   else if (CHARP   (obj2)) ival2 = XCHAR (obj2);
 388   else if (MARKERP (obj2)) ival2 = marker_position (obj2);
 389   else if (FLOATP  (obj2)) ival2 = 0, float_p = 1;
 390   else
 391     {
 392       obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
 393       goto retry;
 394     }
 395
 396   if (!float_p)
 397     {
 398       switch (opcode)
 399         {
 400         case Bplus: ival1 += ival2; break;
 401         case Bdiff: ival1 -= ival2; break;
 402         case Bmult: ival1 *= ival2; break;
 403         case Bquo:
 404           if (ival2 == 0) Fsignal (Qarith_error, Qnil);
 405           ival1 /= ival2;
 406           break;
 407         case Bmax:  if (ival1 < ival2) ival1 = ival2; break;
 408         case Bmin:  if (ival1 > ival2) ival1 = ival2; break;
 409         }
 410       return make_int (ival1);
 411     }
 412   else
 413     {
 414       double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1;
 415       double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2;
 416       switch (opcode)
 417         {
 418         case Bplus: dval1 += dval2; break;
 419         case Bdiff: dval1 -= dval2; break;
 420         case Bmult: dval1 *= dval2; break;
 421         case Bquo:
 422           if (dval2 == 0) Fsignal (Qarith_error, Qnil);
 423           dval1 /= dval2;
 424           break;
 425         case Bmax:  if (dval1 < dval2) dval1 = dval2; break;
 426         case Bmin:  if (dval1 > dval2) dval1 = dval2; break;
 427         }
 428       return make_float (dval1);
 429     }
 430 #else /* !LISP_FLOAT_TYPE */
 431   EMACS_INT ival1, ival2;
 432
 433  retry:
 434
 435   if      (INTP    (obj1)) ival1 = XINT  (obj1);
 436   else if (CHARP   (obj1)) ival1 = XCHAR (obj1);
 437   else if (MARKERP (obj1)) ival1 = marker_position (obj1);
 438   else
 439     {
 440       obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
 441       goto retry;
 442     }
 443
 444   if      (INTP    (obj2)) ival2 = XINT  (obj2);
 445   else if (CHARP   (obj2)) ival2 = XCHAR (obj2);
 446   else if (MARKERP (obj2)) ival2 = marker_position (obj2);
 447   else
 448     {
 449       obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
 450       goto retry;
 451     }
 452
 453   switch (opcode)
 454     {
 455     case Bplus: ival1 += ival2; break;
 456     case Bdiff: ival1 -= ival2; break;
 457     case Bmult: ival1 *= ival2; break;
 458     case Bquo:
 459       if (ival2 == 0) Fsignal (Qarith_error, Qnil);
 460       ival1 /= ival2;
 461       break;
 462     case Bmax:  if (ival1 < ival2) ival1 = ival2; break;
 463     case Bmin:  if (ival1 > ival2) ival1 = ival2; break;
 464     }
 465   return make_int (ival1);
 466 #endif /* !LISP_FLOAT_TYPE */
 467 }
 468
 469 /* Apply compiled-function object FUN to the NARGS evaluated arguments
 470    in ARGS, and return the result of evaluation. */
 471 Lisp_Object
 472 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[])
 473 {
 474   /* This function can GC */
 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   {
 490     /* Fmake_byte_code() guaranteed that f->arglist is a valid list
 491        containing only non-constant symbols. */
 492     LIST_LOOP_3 (symbol, f->arglist, tail)
 493       {
 494         if (EQ (symbol, Qand_rest))
 495           {
 496             tail = XCDR (tail);
 497             symbol  = XCAR (tail);
 498             SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i]));
 499             goto run_code;
 500           }
 501         else if (EQ (symbol, Qand_optional))
 502           optional = 1;
 503         else if (i == nargs && !optional)
 504           goto wrong_number_of_arguments;
 505         else
 506           SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil);
 507       }
 508   }
 509
 510   if (i < nargs)
 511     goto wrong_number_of_arguments;
 512
 513  run_code:
 514
 515   {
 516     Lisp_Object value =
 517       execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions),
 518                                  f->stack_depth,
 519                                  XVECTOR_DATA (f->constants));
 520
 521     /* The attempt to optimize this by only unbinding variables failed
 522        because using buffer-local variables as function parameters
 523        leads to specpdl_ptr->func != 0 */
 524     /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */
 525     UNBIND_TO_GCPRO (speccount, value);
 526     return value;
 527   }
 528
 529  wrong_number_of_arguments:
 530   /* The actual printed compiled_function object is incomprehensible.
 531      Check the backtrace to see if we can get a more meaningful symbol. */
 532   if (EQ (fun, indirect_function (*backtrace_list->function, 0)))
 533     fun = *backtrace_list->function;
 534   return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
 535 }
 536
 537 \f
 538 /* Read next uint8 from the instruction stream. */
 539 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
 540
 541 /* Read next uint16 from the instruction stream. */
 542 #define READ_UINT_2                                             \
 543   (program_ptr += 2,                                            \
 544    (((unsigned int) (unsigned char) program_ptr[-1]) * 256 +    \
 545     ((unsigned int) (unsigned char) program_ptr[-2])))
 546
 547 /* Read next int8 from the instruction stream. */
 548 #define READ_INT_1 ((int) (signed char) *program_ptr++)
 549
 550 /* Read next int16 from the instruction stream. */
 551 #define READ_INT_2                                      \
 552   (program_ptr += 2,                                    \
 553    (((int) (  signed char) program_ptr[-1]) * 256 +     \
 554     ((int) (unsigned char) program_ptr[-2])))
 555
 556 /* Read next int8 from instruction stream; don't advance program_pointer */
 557 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
 558
 559 /* Read next int16 from instruction stream; don't advance program_pointer */
 560 #define PEEK_INT_2                                      \
 561   ((((int) (  signed char) program_ptr[1]) * 256) |     \
 562     ((int) (unsigned char) program_ptr[0]))
 563
 564 /* Do relative jumps from the current location.
 565    We only do a QUIT if we jump backwards, for efficiency.
 566    No infloops without backward jumps! */
 567 #define JUMP_RELATIVE(jump) do {        \
 568   int JR_jump = (jump);                 \
 569   if (JR_jump < 0) QUIT;                \
 570   program_ptr += JR_jump;               \
 571 } while (0)
 572
 573 #define JUMP  JUMP_RELATIVE (PEEK_INT_2)
 574 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
 575
 576 #define JUMP_NEXT  ((void) (program_ptr += 2))
 577 #define JUMPR_NEXT ((void) (program_ptr += 1))
 578
 579 /* Push x onto the execution stack. */
 580 #define PUSH(x) (*++stack_ptr = (x))
 581
 582 /* Pop a value off the execution stack. */
 583 #define POP (*stack_ptr--)
 584
 585 /* Discard n values from the execution stack.  */
 586 #define DISCARD(n) (stack_ptr -= (n))
 587
 588 /* Get the value which is at the top of the execution stack,
 589    but don't pop it. */
 590 #define TOP (*stack_ptr)
 591
 592 /* The actual interpreter for byte code.
 593    This function has been seriously optimized for performance.
 594    Don't change the constructs unless you are willing to do
 595    real benchmarking and profiling work -- martin */
 596
 597
 598 static Lisp_Object
 599 execute_optimized_program (const Opbyte *program,
 600                            int stack_depth,
 601                            Lisp_Object *constants_data)
 602 {
 603   /* This function can GC */
 604   REGISTER const Opbyte *program_ptr = (Opbyte *) program;
 605   REGISTER Lisp_Object *stack_ptr
 606     = alloca_array (Lisp_Object, stack_depth + 1);
 607   int speccount = specpdl_depth ();
 608   struct gcpro gcpro1;
 609
 610 #ifdef BYTE_CODE_METER
 611   Opcode this_opcode = 0;
 612   Opcode prev_opcode;
 613 #endif
 614
 615 #ifdef ERROR_CHECK_BYTE_CODE
 616   Lisp_Object *stack_beg = stack_ptr;
 617   Lisp_Object *stack_end = stack_beg + stack_depth;
 618 #endif
 619
 620   /* Initialize all the objects on the stack to Qnil,
 621      so we can GCPRO the whole stack.
 622      The first element of the stack is actually a dummy. */
 623   {
 624     int i;
 625     Lisp_Object *p;
 626     for (i = stack_depth, p = stack_ptr; i--;)
 627       *++p = Qnil;
 628   }
 629
 630   GCPRO1 (stack_ptr[1]);
 631   gcpro1.nvars = stack_depth;
 632
 633   while (1)
 634     {
 635       REGISTER Opcode opcode = (Opcode) READ_UINT_1;
 636 #ifdef ERROR_CHECK_BYTE_CODE
 637       if (stack_ptr > stack_end)
 638         invalid_byte_code_error ("byte code stack overflow");
 639       if (stack_ptr < stack_beg)
 640         invalid_byte_code_error ("byte code stack underflow");
 641       check_opcode (opcode);
 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           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           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
 765         case Bgoto:
 766           JUMP;
 767           break;
 768
 769         case Bgotoifnil:
 770           if (NILP (POP))
 771             JUMP;
 772           else
 773             JUMP_NEXT;
 774           break;
 775
 776         case Bgotoifnonnil:
 777           if (!NILP (POP))
 778             JUMP;
 779           else
 780             JUMP_NEXT;
 781           break;
 782
 783         case Bgotoifnilelsepop:
 784           if (NILP (TOP))
 785             JUMP;
 786           else
 787             {
 788               DISCARD (1);
 789               JUMP_NEXT;
 790             }
 791           break;
 792
 793         case Bgotoifnonnilelsepop:
 794           if (!NILP (TOP))
 795             JUMP;
 796           else
 797             {
 798               DISCARD (1);
 799               JUMP_NEXT;
 800             }
 801           break;
 802
 803
 804         case BRgoto:
 805           JUMPR;
 806           break;
 807
 808         case BRgotoifnil:
 809           if (NILP (POP))
 810             JUMPR;
 811           else
 812             JUMPR_NEXT;
 813           break;
 814
 815         case BRgotoifnonnil:
 816           if (!NILP (POP))
 817             JUMPR;
 818           else
 819             JUMPR_NEXT;
 820           break;
 821
 822         case BRgotoifnilelsepop:
 823           if (NILP (TOP))
 824             JUMPR;
 825           else
 826             {
 827               DISCARD (1);
 828               JUMPR_NEXT;
 829             }
 830           break;
 831
 832         case BRgotoifnonnilelsepop:
 833           if (!NILP (TOP))
 834             JUMPR;
 835           else
 836             {
 837               DISCARD (1);
 838               JUMPR_NEXT;
 839             }
 840           break;
 841
 842         case Breturn:
 843           UNGCPRO;
 844 #ifdef ERROR_CHECK_BYTE_CODE
 845           /* Binds and unbinds are supposed to be compiled balanced.  */
 846           if (specpdl_depth() != speccount)
 847             invalid_byte_code_error ("unbalanced specbinding stack");
 848 #endif
 849           return TOP;
 850
 851         case Bdiscard:
 852           DISCARD (1);
 853           break;
 854
 855         case Bdup:
 856           {
 857             Lisp_Object arg = TOP;
 858             PUSH (arg);
 859             break;
 860           }
 861
 862         case Bconstant2:
 863           PUSH (constants_data[READ_UINT_2]);
 864           break;
 865
 866         case Bcar:
 867           TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
 868           break;
 869
 870         case Bcdr:
 871           TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
 872           break;
 873
 874
 875         case Bunbind_all:
 876           /* To unbind back to the beginning of this frame.  Not used yet,
 877              but will be needed for tail-recursion elimination. */
 878           unbind_to (speccount, Qnil);
 879           break;
 880
 881         case Bnth:
 882           {
 883             Lisp_Object arg = POP;
 884             TOP = Fcar (Fnthcdr (TOP, arg));
 885             break;
 886           }
 887
 888         case Bsymbolp:
 889           TOP = SYMBOLP (TOP) ? Qt : Qnil;
 890           break;
 891
 892         case Bconsp:
 893           TOP = CONSP (TOP) ? Qt : Qnil;
 894           break;
 895
 896         case Bstringp:
 897           TOP = STRINGP (TOP) ? Qt : Qnil;
 898           break;
 899
 900         case Blistp:
 901           TOP = LISTP (TOP) ? Qt : Qnil;
 902           break;
 903
 904         case Bnumberp:
 905           TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
 906           break;
 907
 908         case Bintegerp:
 909           TOP = INTP (TOP) ? Qt : Qnil;
 910           break;
 911
 912         case Beq:
 913           {
 914             Lisp_Object arg = POP;
 915             TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
 916             break;
 917           }
 918
 919         case Bnot:
 920           TOP = NILP (TOP) ? Qt : Qnil;
 921           break;
 922
 923         case Bcons:
 924           {
 925             Lisp_Object arg = POP;
 926             TOP = Fcons (TOP, arg);
 927             break;
 928           }
 929
 930         case Blist1:
 931           TOP = Fcons (TOP, Qnil);
 932           break;
 933
 934
 935         case BlistN:
 936           n = READ_UINT_1;
 937           goto do_list;
 938
 939         case Blist2:
 940         case Blist3:
 941         case Blist4:
 942           /* common case */
 943           n = opcode - (Blist1 - 1);
 944         do_list:
 945           {
 946             Lisp_Object list = Qnil;
 947           list_loop:
 948             list = Fcons (TOP, list);
 949             if (--n)
 950               {
 951                 DISCARD (1);
 952                 goto list_loop;
 953               }
 954             TOP = list;
 955             break;
 956           }
 957
 958
 959         case Bconcat2:
 960         case Bconcat3:
 961         case Bconcat4:
 962           n = opcode - (Bconcat2 - 2);
 963           goto do_concat;
 964
 965         case BconcatN:
 966           /* common case */
 967           n = READ_UINT_1;
 968         do_concat:
 969           DISCARD (n - 1);
 970           TOP = Fconcat (n, &TOP);
 971           break;
 972
 973
 974         case Blength:
 975           TOP = Flength (TOP);
 976           break;
 977
 978         case Baset:
 979           {
 980             Lisp_Object arg2 = POP;
 981             Lisp_Object arg1 = POP;
 982             TOP = Faset (TOP, arg1, arg2);
 983             break;
 984           }
 985
 986         case Bsymbol_value:
 987           TOP = Fsymbol_value (TOP);
 988           break;
 989
 990         case Bsymbol_function:
 991           TOP = Fsymbol_function (TOP);
 992           break;
 993
 994         case Bget:
 995           {
 996             Lisp_Object arg = POP;
 997             TOP = Fget (TOP, arg, Qnil);
 998             break;
 999           }
1000
1001         case Bsub1:
1002           TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
1003           break;
1004
1005         case Badd1:
1006           TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
1007           break;
1008
1009
1010         case Beqlsign:
1011           {
1012             Lisp_Object arg = POP;
1013             TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
1014             break;
1015           }
1016
1017         case Bgtr:
1018           {
1019             Lisp_Object arg = POP;
1020             TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
1021             break;
1022           }
1023
1024         case Blss:
1025           {
1026             Lisp_Object arg = POP;
1027             TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
1028             break;
1029           }
1030
1031         case Bleq:
1032           {
1033             Lisp_Object arg = POP;
1034             TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
1035             break;
1036           }
1037
1038         case Bgeq:
1039           {
1040             Lisp_Object arg = POP;
1041             TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
1042             break;
1043           }
1044
1045
1046         case Bnegate:
1047           TOP = bytecode_negate (TOP);
1048           break;
1049
1050         case Bnconc:
1051           DISCARD (1);
1052           TOP = bytecode_nconc2 (&TOP);
1053           break;
1054
1055         case Bplus:
1056           {
1057             Lisp_Object arg2 = POP;
1058             Lisp_Object arg1 = TOP;
1059             TOP = INTP (arg1) && INTP (arg2) ?
1060               INT_PLUS (arg1, arg2) :
1061               bytecode_arithop (arg1, arg2, opcode);
1062             break;
1063           }
1064
1065         case Bdiff:
1066           {
1067             Lisp_Object arg2 = POP;
1068             Lisp_Object arg1 = TOP;
1069             TOP = INTP (arg1) && INTP (arg2) ?
1070               INT_MINUS (arg1, arg2) :
1071               bytecode_arithop (arg1, arg2, opcode);
1072             break;
1073           }
1074
1075         case Bmult:
1076         case Bquo:
1077         case Bmax:
1078         case Bmin:
1079           {
1080             Lisp_Object arg = POP;
1081             TOP = bytecode_arithop (TOP, arg, opcode);
1082             break;
1083           }
1084
1085         case Bpoint:
1086           PUSH (make_int (BUF_PT (current_buffer)));
1087           break;
1088
1089         case Binsert:
1090           TOP = Finsert (1, &TOP);
1091           break;
1092
1093         case BinsertN:
1094           n = READ_UINT_1;
1095           DISCARD (n - 1);
1096           TOP = Finsert (n, &TOP);
1097           break;
1098
1099         case Baref:
1100           {
1101             Lisp_Object arg = POP;
1102             TOP = Faref (TOP, arg);
1103             break;
1104           }
1105
1106         case Bmemq:
1107           {
1108             Lisp_Object arg = POP;
1109             TOP = Fmemq (TOP, arg);
1110             break;
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 = (unsigned short) (XINT (Flength (f->arglist)) +
1897                                            varbind_count);
1898       f->instructions =
1899         make_opaque (program, program_length * sizeof (Opbyte));
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)
1986 {
1987   Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
1988
1989   mark_object (f->instructions);
1990   mark_object (f->arglist);
1991   mark_object (f->doc_and_interactive);
1992 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1993   mark_object (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 static const struct lrecord_description compiled_function_description[] = {
2028   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) },
2029   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) },
2030   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) },
2031   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) },
2032 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2033   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) },
2034 #endif
2035   { XD_END }
2036 };
2037
2038 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
2039                                      mark_compiled_function,
2040                                      print_compiled_function, 0,
2041                                      compiled_function_equal,
2042                                      compiled_function_hash,
2043                                      compiled_function_description,
2044                                      Lisp_Compiled_Function);
2045 \f
2046 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
2047 Return t if OBJECT is a byte-compiled function object.
2048 */
2049        (object))
2050 {
2051   return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
2052 }
2053
2054 /************************************************************************/
2055 /*              compiled-function object accessor functions             */
2056 /************************************************************************/
2057
2058 Lisp_Object
2059 compiled_function_arglist (Lisp_Compiled_Function *f)
2060 {
2061   return f->arglist;
2062 }
2063
2064 Lisp_Object
2065 compiled_function_instructions (Lisp_Compiled_Function *f)
2066 {
2067   if (! OPAQUEP (f->instructions))
2068     return f->instructions;
2069
2070   {
2071     /* Invert action performed by optimize_byte_code() */
2072     Lisp_Opaque *opaque = XOPAQUE (f->instructions);
2073
2074     Bufbyte * const buffer =
2075       alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
2076     Bufbyte *bp = buffer;
2077
2078     const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque);
2079     const Opbyte *program_ptr = program;
2080     const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque);
2081
2082     while (program_ptr < program_end)
2083       {
2084         Opcode opcode = (Opcode) READ_UINT_1;
2085         bp += set_charptr_emchar (bp, opcode);
2086         switch (opcode)
2087           {
2088           case Bvarref+7:
2089           case Bvarset+7:
2090           case Bvarbind+7:
2091           case Bcall+7:
2092           case Bunbind+7:
2093           case Bconstant2:
2094             bp += set_charptr_emchar (bp, READ_UINT_1);
2095             bp += set_charptr_emchar (bp, READ_UINT_1);
2096             break;
2097
2098           case Bvarref+6:
2099           case Bvarset+6:
2100           case Bvarbind+6:
2101           case Bcall+6:
2102           case Bunbind+6:
2103           case BlistN:
2104           case BconcatN:
2105           case BinsertN:
2106             bp += set_charptr_emchar (bp, READ_UINT_1);
2107             break;
2108
2109           case Bgoto:
2110           case Bgotoifnil:
2111           case Bgotoifnonnil:
2112           case Bgotoifnilelsepop:
2113           case Bgotoifnonnilelsepop:
2114             {
2115               int jump = READ_INT_2;
2116               Opbyte buf2[2];
2117               Opbyte *buf2p = buf2;
2118               /* Convert back to program-relative address */
2119               WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p);
2120               bp += set_charptr_emchar (bp, buf2[0]);
2121               bp += set_charptr_emchar (bp, buf2[1]);
2122               break;
2123             }
2124
2125           case BRgoto:
2126           case BRgotoifnil:
2127           case BRgotoifnonnil:
2128           case BRgotoifnilelsepop:
2129           case BRgotoifnonnilelsepop:
2130             bp += set_charptr_emchar (bp, READ_INT_1 + 127);
2131             break;
2132
2133           default:
2134             break;
2135           }
2136       }
2137     return make_string (buffer, bp - buffer);
2138   }
2139 }
2140
2141 Lisp_Object
2142 compiled_function_constants (Lisp_Compiled_Function *f)
2143 {
2144   return f->constants;
2145 }
2146
2147 int
2148 compiled_function_stack_depth (Lisp_Compiled_Function *f)
2149 {
2150   return f->stack_depth;
2151 }
2152
2153 /* The compiled_function->doc_and_interactive slot uses the minimal
2154    number of conses, based on compiled_function->flags; it may take
2155    any of the following forms:
2156
2157         doc
2158         interactive
2159         domain
2160         (doc . interactive)
2161         (doc . domain)
2162         (interactive . domain)
2163         (doc . (interactive . domain))
2164  */
2165
2166 /* Caller must check flags.interactivep first */
2167 Lisp_Object
2168 compiled_function_interactive (Lisp_Compiled_Function *f)
2169 {
2170   assert (f->flags.interactivep);
2171   if (f->flags.documentationp && f->flags.domainp)
2172     return XCAR (XCDR (f->doc_and_interactive));
2173   else if (f->flags.documentationp)
2174     return XCDR (f->doc_and_interactive);
2175   else if (f->flags.domainp)
2176     return XCAR (f->doc_and_interactive);
2177   else
2178     return f->doc_and_interactive;
2179 }
2180
2181 /* Caller need not check flags.documentationp first */
2182 Lisp_Object
2183 compiled_function_documentation (Lisp_Compiled_Function *f)
2184 {
2185   if (! f->flags.documentationp)
2186     return Qnil;
2187   else if (f->flags.interactivep && f->flags.domainp)
2188     return XCAR (f->doc_and_interactive);
2189   else if (f->flags.interactivep)
2190     return XCAR (f->doc_and_interactive);
2191   else if (f->flags.domainp)
2192     return XCAR (f->doc_and_interactive);
2193   else
2194     return f->doc_and_interactive;
2195 }
2196
2197 /* Caller need not check flags.domainp first */
2198 Lisp_Object
2199 compiled_function_domain (Lisp_Compiled_Function *f)
2200 {
2201   if (! f->flags.domainp)
2202     return Qnil;
2203   else if (f->flags.documentationp && f->flags.interactivep)
2204     return XCDR (XCDR (f->doc_and_interactive));
2205   else if (f->flags.documentationp)
2206     return XCDR (f->doc_and_interactive);
2207   else if (f->flags.interactivep)
2208     return XCDR (f->doc_and_interactive);
2209   else
2210     return f->doc_and_interactive;
2211 }
2212
2213 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2214
2215 Lisp_Object
2216 compiled_function_annotation (Lisp_Compiled_Function *f)
2217 {
2218   return f->annotated;
2219 }
2220
2221 #endif
2222
2223 /* used only by Snarf-documentation; there must be doc already. */
2224 void
2225 set_compiled_function_documentation (Lisp_Compiled_Function *f,
2226                                      Lisp_Object new_doc)
2227 {
2228   assert (f->flags.documentationp);
2229   assert (INTP (new_doc) || STRINGP (new_doc));
2230
2231   if (f->flags.interactivep && f->flags.domainp)
2232     XCAR (f->doc_and_interactive) = new_doc;
2233   else if (f->flags.interactivep)
2234     XCAR (f->doc_and_interactive) = new_doc;
2235   else if (f->flags.domainp)
2236     XCAR (f->doc_and_interactive) = new_doc;
2237   else
2238     f->doc_and_interactive = new_doc;
2239 }
2240
2241
2242 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2243 Return the argument list of the compiled-function object FUNCTION.
2244 */
2245        (function))
2246 {
2247   CHECK_COMPILED_FUNCTION (function);
2248   return compiled_function_arglist (XCOMPILED_FUNCTION (function));
2249 }
2250
2251 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
2252 Return the byte-opcode string of the compiled-function object FUNCTION.
2253 */
2254        (function))
2255 {
2256   CHECK_COMPILED_FUNCTION (function);
2257   return compiled_function_instructions (XCOMPILED_FUNCTION (function));
2258 }
2259
2260 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
2261 Return the constants vector of the compiled-function object FUNCTION.
2262 */
2263        (function))
2264 {
2265   CHECK_COMPILED_FUNCTION (function);
2266   return compiled_function_constants (XCOMPILED_FUNCTION (function));
2267 }
2268
2269 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2270 Return the maximum stack depth of the compiled-function object FUNCTION.
2271 */
2272        (function))
2273 {
2274   CHECK_COMPILED_FUNCTION (function);
2275   return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function)));
2276 }
2277
2278 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
2279 Return the doc string of the compiled-function object FUNCTION, if available.
2280 Functions that had their doc strings snarfed into the DOC file will have
2281 an integer returned instead of a string.
2282 */
2283        (function))
2284 {
2285   CHECK_COMPILED_FUNCTION (function);
2286   return compiled_function_documentation (XCOMPILED_FUNCTION (function));
2287 }
2288
2289 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2290 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2291 If non-nil, the return value will be a list whose first element is
2292 `interactive' and whose second element is the interactive spec.
2293 */
2294        (function))
2295 {
2296   CHECK_COMPILED_FUNCTION (function);
2297   return XCOMPILED_FUNCTION (function)->flags.interactivep
2298     ? list2 (Qinteractive,
2299              compiled_function_interactive (XCOMPILED_FUNCTION (function)))
2300     : Qnil;
2301 }
2302
2303 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2304
2305 /* Remove the `xx' if you wish to restore this feature */
2306 xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2307 Return the annotation of the compiled-function object FUNCTION, or nil.
2308 The annotation is a piece of information indicating where this
2309 compiled-function object came from.  Generally this will be
2310 a symbol naming a function; or a string naming a file, if the
2311 compiled-function object was not defined in a function; or nil,
2312 if the compiled-function object was not created as a result of
2313 a `load'.
2314 */
2315        (function))
2316 {
2317   CHECK_COMPILED_FUNCTION (function);
2318   return compiled_function_annotation (XCOMPILED_FUNCTION (function));
2319 }
2320
2321 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2322
2323 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
2324 Return the domain of the compiled-function object FUNCTION, or nil.
2325 This is only meaningful if I18N3 was enabled when emacs was compiled.
2326 */
2327        (function))
2328 {
2329   CHECK_COMPILED_FUNCTION (function);
2330   return XCOMPILED_FUNCTION (function)->flags.domainp
2331     ? compiled_function_domain (XCOMPILED_FUNCTION (function))
2332     : Qnil;
2333 }
2334
2335 \f
2336
2337 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
2338 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2339 */
2340        (function))
2341 {
2342   Lisp_Compiled_Function *f;
2343   CHECK_COMPILED_FUNCTION (function);
2344   f = XCOMPILED_FUNCTION (function);
2345
2346   if (OPAQUEP (f->instructions) || STRINGP (f->instructions))
2347     return function;
2348
2349   if (CONSP (f->instructions))
2350     {
2351       Lisp_Object tem = read_doc_string (f->instructions);
2352       if (!CONSP (tem))
2353         signal_simple_error ("Invalid lazy-loaded byte code", tem);
2354       /* v18 or v19 bytecode file.  Need to Ebolify. */
2355       if (f->flags.ebolified && VECTORP (XCDR (tem)))
2356         ebolify_bytecode_constants (XCDR (tem));
2357       f->instructions = XCAR (tem);
2358       f->constants    = XCDR (tem);
2359       return function;
2360     }
2361   ABORT ();
2362   return Qnil; /* not reached */
2363 }
2364
2365 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
2366 Convert compiled function FUNCTION into an optimized internal form.
2367 */
2368        (function))
2369 {
2370   Lisp_Compiled_Function *f;
2371   CHECK_COMPILED_FUNCTION (function);
2372   f = XCOMPILED_FUNCTION (function);
2373
2374   if (OPAQUEP (f->instructions)) /* Already optimized? */
2375     return Qnil;
2376
2377   optimize_compiled_function (function);
2378   return Qnil;
2379 }
2380
2381 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /*
2382 Function used internally in byte-compiled code.
2383 First argument INSTRUCTIONS is a string of byte code.
2384 Second argument CONSTANTS is a vector of constants.
2385 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2386 If STACK-DEPTH is incorrect, Emacs may crash.
2387 */
2388        (instructions, constants, stack_depth))
2389 {
2390   /* This function can GC */
2391   int varbind_count;
2392   int program_length;
2393   Opbyte *program;
2394
2395   CHECK_STRING (instructions);
2396   CHECK_VECTOR (constants);
2397   CHECK_NATNUM (stack_depth);
2398
2399   /* Optimize the `instructions' string, just like when executing a
2400      regular compiled function, but don't save it for later since this is
2401      likely to only be executed once. */
2402   program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
2403   optimize_byte_code (instructions, constants, program,
2404                       &program_length, &varbind_count);
2405   SPECPDL_RESERVE (varbind_count);
2406   return execute_optimized_program (program,
2407                                     XINT (stack_depth),
2408                                     XVECTOR_DATA (constants));
2409 }
2410
2411 \f
2412 void
2413 syms_of_bytecode (void)
2414 {
2415   INIT_LRECORD_IMPLEMENTATION (compiled_function);
2416
2417   DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state);
2418   defsymbol (&Qbyte_code, "byte-code");
2419   defsymbol (&Qcompiled_functionp, "compiled-function-p");
2420
2421   DEFSUBR (Fbyte_code);
2422   DEFSUBR (Ffetch_bytecode);
2423   DEFSUBR (Foptimize_compiled_function);
2424
2425   DEFSUBR (Fcompiled_function_p);
2426   DEFSUBR (Fcompiled_function_instructions);
2427   DEFSUBR (Fcompiled_function_constants);
2428   DEFSUBR (Fcompiled_function_stack_depth);
2429   DEFSUBR (Fcompiled_function_arglist);
2430   DEFSUBR (Fcompiled_function_interactive);
2431   DEFSUBR (Fcompiled_function_doc_string);
2432   DEFSUBR (Fcompiled_function_domain);
2433 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2434   DEFSUBR (Fcompiled_function_annotation);
2435 #endif
2436
2437 #ifdef BYTE_CODE_METER
2438   defsymbol (&Qbyte_code_meter, "byte-code-meter");
2439 #endif
2440 }
2441
2442 void
2443 vars_of_bytecode (void)
2444 {
2445 #ifdef BYTE_CODE_METER
2446
2447   DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
2448 A vector of vectors which holds a histogram of byte code usage.
2449 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2450 opcode CODE has been executed.
2451 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2452 indicates how many times the byte opcodes CODE1 and CODE2 have been
2453 executed in succession.
2454 */ );
2455   DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /*
2456 If non-nil, keep profiling information on byte code usage.
2457 The variable `byte-code-meter' indicates how often each byte opcode is used.
2458 If a symbol has a property named `byte-code-meter' whose value is an
2459 integer, it is incremented each time that symbol's function is called.
2460 */ );
2461
2462   byte_metering_on = 0;
2463   Vbyte_code_meter = make_vector (256, Qzero);
2464   {
2465     int i = 256;
2466     while (i--)
2467       XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero);
2468   }
2469 #endif /* BYTE_CODE_METER */
2470 }