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

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