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

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