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