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