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 = xnew_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   xfree(jumps);
1872 }
1873
1874 /* Optimize the byte code and store the optimized program, only
1875    understood by bytecode.c, in an opaque object in the
1876    instructions slot of the Compiled_Function object. */
1877 void
1878 optimize_compiled_function (Lisp_Object compiled_function)
1879 {
1880   Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
1881   int program_length;
1882   int varbind_count;
1883   Opbyte *program;
1884
1885   /* If we have not actually read the bytecode string
1886      and constants vector yet, fetch them from the file.  */
1887   if (CONSP (f->instructions))
1888     Ffetch_bytecode (compiled_function);
1889
1890   if (STRINGP (f->instructions))
1891     {
1892       /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
1893          which would be slightly more `proper' */
1894       program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
1895       optimize_byte_code (f->instructions, f->constants,
1896                           program, &program_length, &varbind_count);
1897       f->specpdl_depth = (unsigned short) (XINT (Flength (f->arglist)) +
1898                                            varbind_count);
1899       f->instructions =
1900         make_opaque (program, program_length * sizeof (Opbyte));
1901     }
1902
1903   assert (OPAQUEP (f->instructions));
1904 }
1905 \f
1906 /************************************************************************/
1907 /*              The compiled-function object type                       */
1908 /************************************************************************/
1909 static void
1910 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
1911                          int escapeflag)
1912 {
1913   /* This function can GC */
1914   Lisp_Compiled_Function *f =
1915     XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
1916   int docp = f->flags.documentationp;
1917   int intp = f->flags.interactivep;
1918   struct gcpro gcpro1, gcpro2;
1919   char buf[100];
1920   GCPRO2 (obj, printcharfun);
1921
1922   write_c_string (print_readably ? "#[" : "#<compiled-function ", printcharfun);
1923 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1924   if (!print_readably)
1925     {
1926       Lisp_Object ann = compiled_function_annotation (f);
1927       if (!NILP (ann))
1928         {
1929           write_c_string ("(from ", printcharfun);
1930           print_internal (ann, printcharfun, 1);
1931           write_c_string (") ", printcharfun);
1932         }
1933     }
1934 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1935   /* COMPILED_ARGLIST = 0 */
1936   print_internal (compiled_function_arglist (f), printcharfun, escapeflag);
1937
1938   /* COMPILED_INSTRUCTIONS = 1 */
1939   write_c_string (" ", printcharfun);
1940   {
1941     struct gcpro ngcpro1;
1942     Lisp_Object instructions = compiled_function_instructions (f);
1943     NGCPRO1 (instructions);
1944     if (STRINGP (instructions) && !print_readably)
1945       {
1946         /* We don't usually want to see that junk in the bytecode. */
1947         sprintf (buf, "\"...(%ld)\"",
1948                  (long) XSTRING_CHAR_LENGTH (instructions));
1949         write_c_string (buf, printcharfun);
1950       }
1951     else
1952       print_internal (instructions, printcharfun, escapeflag);
1953     NUNGCPRO;
1954   }
1955
1956   /* COMPILED_CONSTANTS = 2 */
1957   write_c_string (" ", printcharfun);
1958   print_internal (compiled_function_constants (f), printcharfun, escapeflag);
1959
1960   /* COMPILED_STACK_DEPTH = 3 */
1961   sprintf (buf, " %d", compiled_function_stack_depth (f));
1962   write_c_string (buf, printcharfun);
1963
1964   /* COMPILED_DOC_STRING = 4 */
1965   if (docp || intp)
1966     {
1967       write_c_string (" ", printcharfun);
1968       print_internal (compiled_function_documentation (f), printcharfun,
1969                       escapeflag);
1970     }
1971
1972   /* COMPILED_INTERACTIVE = 5 */
1973   if (intp)
1974     {
1975       write_c_string (" ", printcharfun);
1976       print_internal (compiled_function_interactive (f), printcharfun,
1977                       escapeflag);
1978     }
1979
1980   UNGCPRO;
1981   write_c_string (print_readably ? "]" : ">", printcharfun);
1982 }
1983
1984
1985 static Lisp_Object
1986 mark_compiled_function (Lisp_Object obj)
1987 {
1988   Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
1989
1990   mark_object (f->instructions);
1991   mark_object (f->arglist);
1992   mark_object (f->doc_and_interactive);
1993 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1994   mark_object (f->annotated);
1995 #endif
1996   /* tail-recurse on constants */
1997   return f->constants;
1998 }
1999
2000 static int
2001 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2002 {
2003   Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1);
2004   Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2);
2005   return
2006     (f1->flags.documentationp == f2->flags.documentationp &&
2007      f1->flags.interactivep   == f2->flags.interactivep   &&
2008      f1->flags.domainp        == f2->flags.domainp        && /* I18N3 */
2009      internal_equal (compiled_function_instructions (f1),
2010                      compiled_function_instructions (f2), depth + 1) &&
2011      internal_equal (f1->constants,    f2->constants,    depth + 1) &&
2012      internal_equal (f1->arglist,      f2->arglist,      depth + 1) &&
2013      internal_equal (f1->doc_and_interactive,
2014                      f2->doc_and_interactive, depth + 1));
2015 }
2016
2017 static unsigned long
2018 compiled_function_hash (Lisp_Object obj, int depth)
2019 {
2020   Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
2021   return HASH3 ((f->flags.documentationp << 2) +
2022                 (f->flags.interactivep << 1) +
2023                 f->flags.domainp,
2024                 internal_hash (f->instructions, depth + 1),
2025                 internal_hash (f->constants,    depth + 1));
2026 }
2027
2028 static const struct lrecord_description compiled_function_description[] = {
2029   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) },
2030   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) },
2031   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) },
2032   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) },
2033 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2034   { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) },
2035 #endif
2036   { XD_END }
2037 };
2038
2039 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
2040                                      mark_compiled_function,
2041                                      print_compiled_function, 0,
2042                                      compiled_function_equal,
2043                                      compiled_function_hash,
2044                                      compiled_function_description,
2045                                      Lisp_Compiled_Function);
2046 \f
2047 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
2048 Return t if OBJECT is a byte-compiled function object.
2049 */
2050        (object))
2051 {
2052   return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
2053 }
2054
2055 /************************************************************************/
2056 /*              compiled-function object accessor functions             */
2057 /************************************************************************/
2058
2059 Lisp_Object
2060 compiled_function_arglist (Lisp_Compiled_Function *f)
2061 {
2062   return f->arglist;
2063 }
2064
2065 Lisp_Object
2066 compiled_function_instructions (Lisp_Compiled_Function *f)
2067 {
2068   if (! OPAQUEP (f->instructions))
2069     return f->instructions;
2070
2071   {
2072     /* Invert action performed by optimize_byte_code() */
2073     Lisp_Opaque *opaque = XOPAQUE (f->instructions);
2074
2075     Bufbyte * const buffer =
2076       alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
2077     Bufbyte *bp = buffer;
2078
2079     const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque);
2080     const Opbyte *program_ptr = program;
2081     const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque);
2082
2083     while (program_ptr < program_end)
2084       {
2085         Opcode opcode = (Opcode) READ_UINT_1;
2086         bp += set_charptr_emchar (bp, opcode);
2087         switch (opcode)
2088           {
2089           case Bvarref+7:
2090           case Bvarset+7:
2091           case Bvarbind+7:
2092           case Bcall+7:
2093           case Bunbind+7:
2094           case Bconstant2:
2095             bp += set_charptr_emchar (bp, READ_UINT_1);
2096             bp += set_charptr_emchar (bp, READ_UINT_1);
2097             break;
2098
2099           case Bvarref+6:
2100           case Bvarset+6:
2101           case Bvarbind+6:
2102           case Bcall+6:
2103           case Bunbind+6:
2104           case BlistN:
2105           case BconcatN:
2106           case BinsertN:
2107             bp += set_charptr_emchar (bp, READ_UINT_1);
2108             break;
2109
2110           case Bgoto:
2111           case Bgotoifnil:
2112           case Bgotoifnonnil:
2113           case Bgotoifnilelsepop:
2114           case Bgotoifnonnilelsepop:
2115             {
2116               int jump = READ_INT_2;
2117               Opbyte buf2[2];
2118               Opbyte *buf2p = buf2;
2119               /* Convert back to program-relative address */
2120               WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p);
2121               bp += set_charptr_emchar (bp, buf2[0]);
2122               bp += set_charptr_emchar (bp, buf2[1]);
2123               break;
2124             }
2125
2126           case BRgoto:
2127           case BRgotoifnil:
2128           case BRgotoifnonnil:
2129           case BRgotoifnilelsepop:
2130           case BRgotoifnonnilelsepop:
2131             bp += set_charptr_emchar (bp, READ_INT_1 + 127);
2132             break;
2133
2134           default:
2135             break;
2136           }
2137       }
2138     return make_string (buffer, bp - buffer);
2139   }
2140 }
2141
2142 Lisp_Object
2143 compiled_function_constants (Lisp_Compiled_Function *f)
2144 {
2145   return f->constants;
2146 }
2147
2148 int
2149 compiled_function_stack_depth (Lisp_Compiled_Function *f)
2150 {
2151   return f->stack_depth;
2152 }
2153
2154 /* The compiled_function->doc_and_interactive slot uses the minimal
2155    number of conses, based on compiled_function->flags; it may take
2156    any of the following forms:
2157
2158         doc
2159         interactive
2160         domain
2161         (doc . interactive)
2162         (doc . domain)
2163         (interactive . domain)
2164         (doc . (interactive . domain))
2165  */
2166
2167 /* Caller must check flags.interactivep first */
2168 Lisp_Object
2169 compiled_function_interactive (Lisp_Compiled_Function *f)
2170 {
2171   assert (f->flags.interactivep);
2172   if (f->flags.documentationp && f->flags.domainp)
2173     return XCAR (XCDR (f->doc_and_interactive));
2174   else if (f->flags.documentationp)
2175     return XCDR (f->doc_and_interactive);
2176   else if (f->flags.domainp)
2177     return XCAR (f->doc_and_interactive);
2178   else
2179     return f->doc_and_interactive;
2180 }
2181
2182 /* Caller need not check flags.documentationp first */
2183 Lisp_Object
2184 compiled_function_documentation (Lisp_Compiled_Function *f)
2185 {
2186   if (! f->flags.documentationp)
2187     return Qnil;
2188   else if (f->flags.interactivep && f->flags.domainp)
2189     return XCAR (f->doc_and_interactive);
2190   else if (f->flags.interactivep)
2191     return XCAR (f->doc_and_interactive);
2192   else if (f->flags.domainp)
2193     return XCAR (f->doc_and_interactive);
2194   else
2195     return f->doc_and_interactive;
2196 }
2197
2198 /* Caller need not check flags.domainp first */
2199 Lisp_Object
2200 compiled_function_domain (Lisp_Compiled_Function *f)
2201 {
2202   if (! f->flags.domainp)
2203     return Qnil;
2204   else if (f->flags.documentationp && f->flags.interactivep)
2205     return XCDR (XCDR (f->doc_and_interactive));
2206   else if (f->flags.documentationp)
2207     return XCDR (f->doc_and_interactive);
2208   else if (f->flags.interactivep)
2209     return XCDR (f->doc_and_interactive);
2210   else
2211     return f->doc_and_interactive;
2212 }
2213
2214 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2215
2216 Lisp_Object
2217 compiled_function_annotation (Lisp_Compiled_Function *f)
2218 {
2219   return f->annotated;
2220 }
2221
2222 #endif
2223
2224 /* used only by Snarf-documentation; there must be doc already. */
2225 void
2226 set_compiled_function_documentation (Lisp_Compiled_Function *f,
2227                                      Lisp_Object new_doc)
2228 {
2229   assert (f->flags.documentationp);
2230   assert (INTP (new_doc) || STRINGP (new_doc));
2231
2232   if (f->flags.interactivep && f->flags.domainp)
2233     XCAR (f->doc_and_interactive) = new_doc;
2234   else if (f->flags.interactivep)
2235     XCAR (f->doc_and_interactive) = new_doc;
2236   else if (f->flags.domainp)
2237     XCAR (f->doc_and_interactive) = new_doc;
2238   else
2239     f->doc_and_interactive = new_doc;
2240 }
2241
2242
2243 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2244 Return the argument list of the compiled-function object FUNCTION.
2245 */
2246        (function))
2247 {
2248   CHECK_COMPILED_FUNCTION (function);
2249   return compiled_function_arglist (XCOMPILED_FUNCTION (function));
2250 }
2251
2252 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
2253 Return the byte-opcode string of the compiled-function object FUNCTION.
2254 */
2255        (function))
2256 {
2257   CHECK_COMPILED_FUNCTION (function);
2258   return compiled_function_instructions (XCOMPILED_FUNCTION (function));
2259 }
2260
2261 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
2262 Return the constants vector of the compiled-function object FUNCTION.
2263 */
2264        (function))
2265 {
2266   CHECK_COMPILED_FUNCTION (function);
2267   return compiled_function_constants (XCOMPILED_FUNCTION (function));
2268 }
2269
2270 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2271 Return the maximum stack depth of the compiled-function object FUNCTION.
2272 */
2273        (function))
2274 {
2275   CHECK_COMPILED_FUNCTION (function);
2276   return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function)));
2277 }
2278
2279 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
2280 Return the doc string of the compiled-function object FUNCTION, if available.
2281 Functions that had their doc strings snarfed into the DOC file will have
2282 an integer returned instead of a string.
2283 */
2284        (function))
2285 {
2286   CHECK_COMPILED_FUNCTION (function);
2287   return compiled_function_documentation (XCOMPILED_FUNCTION (function));
2288 }
2289
2290 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2291 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2292 If non-nil, the return value will be a list whose first element is
2293 `interactive' and whose second element is the interactive spec.
2294 */
2295        (function))
2296 {
2297   CHECK_COMPILED_FUNCTION (function);
2298   return XCOMPILED_FUNCTION (function)->flags.interactivep
2299     ? list2 (Qinteractive,
2300              compiled_function_interactive (XCOMPILED_FUNCTION (function)))
2301     : Qnil;
2302 }
2303
2304 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2305
2306 /* Remove the `xx' if you wish to restore this feature */
2307 xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2308 Return the annotation of the compiled-function object FUNCTION, or nil.
2309 The annotation is a piece of information indicating where this
2310 compiled-function object came from.  Generally this will be
2311 a symbol naming a function; or a string naming a file, if the
2312 compiled-function object was not defined in a function; or nil,
2313 if the compiled-function object was not created as a result of
2314 a `load'.
2315 */
2316        (function))
2317 {
2318   CHECK_COMPILED_FUNCTION (function);
2319   return compiled_function_annotation (XCOMPILED_FUNCTION (function));
2320 }
2321
2322 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2323
2324 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
2325 Return the domain of the compiled-function object FUNCTION, or nil.
2326 This is only meaningful if I18N3 was enabled when emacs was compiled.
2327 */
2328        (function))
2329 {
2330   CHECK_COMPILED_FUNCTION (function);
2331   return XCOMPILED_FUNCTION (function)->flags.domainp
2332     ? compiled_function_domain (XCOMPILED_FUNCTION (function))
2333     : Qnil;
2334 }
2335
2336 \f
2337
2338 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
2339 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2340 */
2341        (function))
2342 {
2343   Lisp_Compiled_Function *f;
2344   CHECK_COMPILED_FUNCTION (function);
2345   f = XCOMPILED_FUNCTION (function);
2346
2347   if (OPAQUEP (f->instructions) || STRINGP (f->instructions))
2348     return function;
2349
2350   if (CONSP (f->instructions))
2351     {
2352       Lisp_Object tem = read_doc_string (f->instructions);
2353       if (!CONSP (tem))
2354         signal_simple_error ("Invalid lazy-loaded byte code", tem);
2355       /* v18 or v19 bytecode file.  Need to Ebolify. */
2356       if (f->flags.ebolified && VECTORP (XCDR (tem)))
2357         ebolify_bytecode_constants (XCDR (tem));
2358       f->instructions = XCAR (tem);
2359       f->constants    = XCDR (tem);
2360       return function;
2361     }
2362   ABORT ();
2363   return Qnil; /* not reached */
2364 }
2365
2366 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
2367 Convert compiled function FUNCTION into an optimized internal form.
2368 */
2369        (function))
2370 {
2371   Lisp_Compiled_Function *f;
2372   CHECK_COMPILED_FUNCTION (function);
2373   f = XCOMPILED_FUNCTION (function);
2374
2375   if (OPAQUEP (f->instructions)) /* Already optimized? */
2376     return Qnil;
2377
2378   optimize_compiled_function (function);
2379   return Qnil;
2380 }
2381
2382 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /*
2383 Function used internally in byte-compiled code.
2384 First argument INSTRUCTIONS is a string of byte code.
2385 Second argument CONSTANTS is a vector of constants.
2386 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2387 If STACK-DEPTH is incorrect, Emacs may crash.
2388 */
2389        (instructions, constants, stack_depth))
2390 {
2391   /* This function can GC */
2392   int varbind_count;
2393   int program_length;
2394   Opbyte *program;
2395
2396   CHECK_STRING (instructions);
2397   CHECK_VECTOR (constants);
2398   CHECK_NATNUM (stack_depth);
2399
2400   /* Optimize the `instructions' string, just like when executing a
2401      regular compiled function, but don't save it for later since this is
2402      likely to only be executed once. */
2403   program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
2404   optimize_byte_code (instructions, constants, program,
2405                       &program_length, &varbind_count);
2406   SPECPDL_RESERVE (varbind_count);
2407   return execute_optimized_program (program,
2408                                     XINT (stack_depth),
2409                                     XVECTOR_DATA (constants));
2410 }
2411
2412 \f
2413 void
2414 syms_of_bytecode (void)
2415 {
2416   INIT_LRECORD_IMPLEMENTATION (compiled_function);
2417
2418   DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state);
2419   defsymbol (&Qbyte_code, "byte-code");
2420   defsymbol (&Qcompiled_functionp, "compiled-function-p");
2421
2422   DEFSUBR (Fbyte_code);
2423   DEFSUBR (Ffetch_bytecode);
2424   DEFSUBR (Foptimize_compiled_function);
2425
2426   DEFSUBR (Fcompiled_function_p);
2427   DEFSUBR (Fcompiled_function_instructions);
2428   DEFSUBR (Fcompiled_function_constants);
2429   DEFSUBR (Fcompiled_function_stack_depth);
2430   DEFSUBR (Fcompiled_function_arglist);
2431   DEFSUBR (Fcompiled_function_interactive);
2432   DEFSUBR (Fcompiled_function_doc_string);
2433   DEFSUBR (Fcompiled_function_domain);
2434 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2435   DEFSUBR (Fcompiled_function_annotation);
2436 #endif
2437
2438 #ifdef BYTE_CODE_METER
2439   defsymbol (&Qbyte_code_meter, "byte-code-meter");
2440 #endif
2441 }
2442
2443 void
2444 vars_of_bytecode (void)
2445 {
2446 #ifdef BYTE_CODE_METER
2447
2448   DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
2449 A vector of vectors which holds a histogram of byte code usage.
2450 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2451 opcode CODE has been executed.
2452 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2453 indicates how many times the byte opcodes CODE1 and CODE2 have been
2454 executed in succession.
2455 */ );
2456   DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /*
2457 If non-nil, keep profiling information on byte code usage.
2458 The variable `byte-code-meter' indicates how often each byte opcode is used.
2459 If a symbol has a property named `byte-code-meter' whose value is an
2460 integer, it is incremented each time that symbol's function is called.
2461 */ );
2462
2463   byte_metering_on = 0;
2464   Vbyte_code_meter = make_vector (256, Qzero);
2465   {
2466     int i = 256;
2467     while (i--)
2468       XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero);
2469   }
2470 #endif /* BYTE_CODE_METER */
2471 }