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

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