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