Mercurial > hg > xemacs-beta

comparison src/bytecode.c @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents aabb7f5b1c81
children a86b2b5e0111
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
26 26
27 /* Authorship: 27 /* Authorship:
28 28
29 FSF: long ago. 29 FSF: long ago.
30 30
31 hacked on by jwz@netscape.com 1991-06 31 hacked on by jwz@jwz.org 1991-06
32 o added a compile-time switch to turn on simple sanity checking; 32 o added a compile-time switch to turn on simple sanity checking;
33 o put back the obsolete byte-codes for error-detection; 33 o put back the obsolete byte-codes for error-detection;
34 o added a new instruction, unbind_all, which I will use for 34 o added a new instruction, unbind_all, which I will use for
35 tail-recursion elimination; 35 tail-recursion elimination;
36 o made temp_output_buffer_show be called with the right number 36 o made temp_output_buffer_show be called with the right number
54 #include "buffer.h" 54 #include "buffer.h"
55 #include "bytecode.h" 55 #include "bytecode.h"
56 #include "opaque.h" 56 #include "opaque.h"
57 #include "syntax.h" 57 #include "syntax.h"
58 58
59 #include <stddef.h>
60 #include <limits.h> 59 #include <limits.h>
61 60
62 EXFUN (Ffetch_bytecode, 1); 61 EXFUN (Ffetch_bytecode, 1);
63 62
64 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code; 63 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
215 214
216 215
217 static void invalid_byte_code_error (char *error_message, ...); 216 static void invalid_byte_code_error (char *error_message, ...);
218 217
219 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr, 218 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
220 CONST Opbyte *program_ptr, 219 const Opbyte *program_ptr,
221 Opcode opcode); 220 Opcode opcode);
222 221
223 static Lisp_Object execute_optimized_program (CONST Opbyte *program, 222 static Lisp_Object execute_optimized_program (const Opbyte *program,
224 int stack_depth, 223 int stack_depth,
225 Lisp_Object *constants_data); 224 Lisp_Object *constants_data);
226 225
227 extern Lisp_Object Qand_rest, Qand_optional; 226 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 227
235 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram. 228 /* 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. */ 229 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
237 /* #define BYTE_CODE_METER */ 230 /* #define BYTE_CODE_METER */
238 231
240 #ifdef BYTE_CODE_METER 233 #ifdef BYTE_CODE_METER
241 234
242 Lisp_Object Vbyte_code_meter, Qbyte_code_meter; 235 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
243 int byte_metering_on; 236 int byte_metering_on;
244 237
245 #define METER_2(code1, code2) \ 238 static void
246 XINT (XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[(code1)])[(code2)]) 239 meter_code (Opcode prev_opcode, Opcode this_opcode)
247 240 {
248 #define METER_1(code) METER_2 (0, (code)) 241 if (byte_metering_on)
249 242 {
250 #define METER_CODE(last_code, this_code) do { \ 243 Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]);
251 if (byte_metering_on) \ 244 p[0] = INT_PLUS1 (p[0]);
252 { \ 245 if (prev_opcode)
253 if (METER_1 (this_code) != ((1<<VALBITS)-1)) \ 246 p[prev_opcode] = INT_PLUS1 (p[prev_opcode]);
254 METER_1 (this_code)++; \ 247 }
255 if (last_code \ 248 }
256 && METER_2 (last_code, this_code) != ((1<<VALBITS)-1)) \
257 METER_2 (last_code, this_code)++; \
258 } \
259 } while (0)
260 249
261 #endif /* BYTE_CODE_METER */ 250 #endif /* BYTE_CODE_METER */
262 251
263 252
264 static Lisp_Object 253 static Lisp_Object
265 bytecode_negate (Lisp_Object obj) 254 bytecode_negate (Lisp_Object obj)
266 { 255 {
267 retry: 256 retry:
268 257
258 if (INTP (obj)) return make_int (- XINT (obj));
269 #ifdef LISP_FLOAT_TYPE 259 #ifdef LISP_FLOAT_TYPE
270 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj)); 260 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj));
271 #endif 261 #endif
272 if (CHARP (obj)) return make_int (- ((int) XCHAR (obj))); 262 if (CHARP (obj)) return make_int (- ((int) XCHAR (obj)));
273 if (MARKERP (obj)) return make_int (- ((int) marker_position (obj))); 263 if (MARKERP (obj)) return make_int (- ((int) marker_position (obj)));
274 if (INTP (obj)) return make_int (- XINT (obj));
275 264
276 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); 265 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
277 goto retry; 266 goto retry;
278 } 267 }
279 268
303 { 292 {
304 retry: 293 retry:
305 294
306 #ifdef LISP_FLOAT_TYPE 295 #ifdef LISP_FLOAT_TYPE
307 { 296 {
308 int ival1, ival2; 297 EMACS_INT ival1, ival2;
309 298
310 if (INTP (obj1)) ival1 = XINT (obj1); 299 if (INTP (obj1)) ival1 = XINT (obj1);
311 else if (CHARP (obj1)) ival1 = XCHAR (obj1); 300 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
312 else if (MARKERP (obj1)) ival1 = marker_position (obj1); 301 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
313 else goto arithcompare_float; 302 else goto arithcompare_float;
347 336
348 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; 337 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
349 } 338 }
350 #else /* !LISP_FLOAT_TYPE */ 339 #else /* !LISP_FLOAT_TYPE */
351 { 340 {
352 int ival1, ival2; 341 EMACS_INT ival1, ival2;
353 342
354 if (INTP (obj1)) ival1 = XINT (obj1); 343 if (INTP (obj1)) ival1 = XINT (obj1);
355 else if (CHARP (obj1)) ival1 = XCHAR (obj1); 344 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
356 else if (MARKERP (obj1)) ival1 = marker_position (obj1); 345 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
357 else 346 else
376 365
377 static Lisp_Object 366 static Lisp_Object
378 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode) 367 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
379 { 368 {
380 #ifdef LISP_FLOAT_TYPE 369 #ifdef LISP_FLOAT_TYPE
381 int ival1, ival2; 370 EMACS_INT ival1, ival2;
382 int float_p; 371 int float_p;
383 372
384 retry: 373 retry:
385 374
386 float_p = 0; 375 float_p = 0;
438 case Bmin: if (dval1 > dval2) dval1 = dval2; break; 427 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
439 } 428 }
440 return make_float (dval1); 429 return make_float (dval1);
441 } 430 }
442 #else /* !LISP_FLOAT_TYPE */ 431 #else /* !LISP_FLOAT_TYPE */
443 int ival1, ival2; 432 EMACS_INT ival1, ival2;
444 433
445 retry: 434 retry:
446 435
447 if (INTP (obj1)) ival1 = XINT (obj1); 436 if (INTP (obj1)) ival1 = XINT (obj1);
448 else if (CHARP (obj1)) ival1 = XCHAR (obj1); 437 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
536 UNBIND_TO_GCPRO (speccount, value); 525 UNBIND_TO_GCPRO (speccount, value);
537 return value; 526 return value;
538 } 527 }
539 528
540 wrong_number_of_arguments: 529 wrong_number_of_arguments:
530 /* The actual printed compiled_function object is incomprehensible.
531 Check the backtrace to see if we can get a more meaningful symbol. */
532 if (EQ (fun, indirect_function (*backtrace_list->function, 0)))
533 fun = *backtrace_list->function;
541 return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs))); 534 return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
542 } 535 }
543 536
544 537
545 /* Read next uint8 from the instruction stream. */ 538 /* Read next uint8 from the instruction stream. */
601 Don't change the constructs unless you are willing to do 594 Don't change the constructs unless you are willing to do
602 real benchmarking and profiling work -- martin */ 595 real benchmarking and profiling work -- martin */
603 596
604 597
605 static Lisp_Object 598 static Lisp_Object
606 execute_optimized_program (CONST Opbyte *program, 599 execute_optimized_program (const Opbyte *program,
607 int stack_depth, 600 int stack_depth,
608 Lisp_Object *constants_data) 601 Lisp_Object *constants_data)
609 { 602 {
610 /* This function can GC */ 603 /* This function can GC */
611 REGISTER CONST Opbyte *program_ptr = (Opbyte *) program; 604 REGISTER const Opbyte *program_ptr = (Opbyte *) program;
612 REGISTER Lisp_Object *stack_ptr 605 REGISTER Lisp_Object *stack_ptr
613 = alloca_array (Lisp_Object, stack_depth + 1); 606 = alloca_array (Lisp_Object, stack_depth + 1);
614 int speccount = specpdl_depth (); 607 int speccount = specpdl_depth ();
615 struct gcpro gcpro1; 608 struct gcpro gcpro1;
616 609
648 #endif 641 #endif
649 642
650 #ifdef BYTE_CODE_METER 643 #ifdef BYTE_CODE_METER
651 prev_opcode = this_opcode; 644 prev_opcode = this_opcode;
652 this_opcode = opcode; 645 this_opcode = opcode;
653 METER_CODE (prev_opcode, this_opcode); 646 meter_code (prev_opcode, this_opcode);
654 #endif 647 #endif
655 648
656 switch (opcode) 649 switch (opcode)
657 { 650 {
658 REGISTER int n; 651 REGISTER int n;
691 case Bvarset+7: n = READ_UINT_2; goto do_varset; 684 case Bvarset+7: n = READ_UINT_2; goto do_varset;
692 case Bvarset+6: n = READ_UINT_1; /* most common */ 685 case Bvarset+6: n = READ_UINT_1; /* most common */
693 do_varset: 686 do_varset:
694 { 687 {
695 Lisp_Object symbol = constants_data[n]; 688 Lisp_Object symbol = constants_data[n];
696 struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); 689 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
697 Lisp_Object old_value = symbol_ptr->value; 690 Lisp_Object old_value = symbol_ptr->value;
698 Lisp_Object new_value = POP; 691 Lisp_Object new_value = POP;
699 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) 692 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
700 symbol_ptr->value = new_value; 693 symbol_ptr->value = new_value;
701 else 694 else
712 case Bvarbind+7: n = READ_UINT_2; goto do_varbind; 705 case Bvarbind+7: n = READ_UINT_2; goto do_varbind;
713 case Bvarbind+6: n = READ_UINT_1; /* most common */ 706 case Bvarbind+6: n = READ_UINT_1; /* most common */
714 do_varbind: 707 do_varbind:
715 { 708 {
716 Lisp_Object symbol = constants_data[n]; 709 Lisp_Object symbol = constants_data[n];
717 struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); 710 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
718 Lisp_Object old_value = symbol_ptr->value; 711 Lisp_Object old_value = symbol_ptr->value;
719 Lisp_Object new_value = POP; 712 Lisp_Object new_value = POP;
720 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) 713 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
721 { 714 {
722 specpdl_ptr->symbol = symbol; 715 specpdl_ptr->symbol = symbol;
765 UNBIND_TO (specpdl_depth() - 758 UNBIND_TO (specpdl_depth() -
766 (opcode < Bunbind+6 ? opcode-Bunbind : 759 (opcode < Bunbind+6 ? opcode-Bunbind :
767 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2)); 760 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
768 break; 761 break;
769 762
763
770 case Bgoto: 764 case Bgoto:
771 JUMP; 765 JUMP;
772 break; 766 break;
773 767
774 case Bgotoifnil: 768 case Bgotoifnil:
1002 TOP = Fget (TOP, arg, Qnil); 996 TOP = Fget (TOP, arg, Qnil);
1003 break; 997 break;
1004 } 998 }
1005 999
1006 case Bsub1: 1000 case Bsub1:
1007 TOP = INTP (TOP) ? make_int (XINT (TOP) - 1) : Fsub1 (TOP); 1001 TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
1008 break; 1002 break;
1009 1003
1010 case Badd1: 1004 case Badd1:
1011 TOP = INTP (TOP) ? make_int (XINT (TOP) + 1) : Fadd1 (TOP); 1005 TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
1012 break; 1006 break;
1013 1007
1014 1008
1015 case Beqlsign: 1009 case Beqlsign:
1016 { 1010 {
1060 case Bplus: 1054 case Bplus:
1061 { 1055 {
1062 Lisp_Object arg2 = POP; 1056 Lisp_Object arg2 = POP;
1063 Lisp_Object arg1 = TOP; 1057 Lisp_Object arg1 = TOP;
1064 TOP = INTP (arg1) && INTP (arg2) ? 1058 TOP = INTP (arg1) && INTP (arg2) ?
1065 make_int (XINT (arg1) + XINT (arg2)) : 1059 INT_PLUS (arg1, arg2) :
1066 bytecode_arithop (arg1, arg2, opcode); 1060 bytecode_arithop (arg1, arg2, opcode);
1067 break; 1061 break;
1068 } 1062 }
1069 1063
1070 case Bdiff: 1064 case Bdiff:
1071 { 1065 {
1072 Lisp_Object arg2 = POP; 1066 Lisp_Object arg2 = POP;
1073 Lisp_Object arg1 = TOP; 1067 Lisp_Object arg1 = TOP;
1074 TOP = INTP (arg1) && INTP (arg2) ? 1068 TOP = INTP (arg1) && INTP (arg2) ?
1075 make_int (XINT (arg1) - XINT (arg2)) : 1069 INT_MINUS (arg1, arg2) :
1076 bytecode_arithop (arg1, arg2, opcode); 1070 bytecode_arithop (arg1, arg2, opcode);
1077 break; 1071 break;
1078 } 1072 }
1079 1073
1080 case Bmult: 1074 case Bmult:
1112 { 1106 {
1113 Lisp_Object arg = POP; 1107 Lisp_Object arg = POP;
1114 TOP = Fmemq (TOP, arg); 1108 TOP = Fmemq (TOP, arg);
1115 break; 1109 break;
1116 } 1110 }
1117
1118 1111
1119 case Bset: 1112 case Bset:
1120 { 1113 {
1121 Lisp_Object arg = POP; 1114 Lisp_Object arg = POP;
1122 TOP = Fset (TOP, arg); 1115 TOP = Fset (TOP, arg);
1226 rarely executed code, to minimize cache misses. 1219 rarely executed code, to minimize cache misses.
1227 1220
1228 Don't make this function static, since then the compiler might inline it. */ 1221 Don't make this function static, since then the compiler might inline it. */
1229 Lisp_Object * 1222 Lisp_Object *
1230 execute_rare_opcode (Lisp_Object *stack_ptr, 1223 execute_rare_opcode (Lisp_Object *stack_ptr,
1231 CONST Opbyte *program_ptr, 1224 const Opbyte *program_ptr,
1232 Opcode opcode) 1225 Opcode opcode)
1233 { 1226 {
1234 switch (opcode) 1227 switch (opcode)
1235 { 1228 {
1236 1229
1496 va_list args; 1489 va_list args;
1497 char *buf = alloca_array (char, strlen (error_message) + 128); 1490 char *buf = alloca_array (char, strlen (error_message) + 128);
1498 1491
1499 sprintf (buf, "%s", error_message); 1492 sprintf (buf, "%s", error_message);
1500 va_start (args, error_message); 1493 va_start (args, error_message);
1501 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (buf), Qnil, -1, 1494 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (buf), Qnil, -1,
1502 args); 1495 args);
1503 va_end (args); 1496 va_end (args);
1504 1497
1505 signal_error (Qinvalid_byte_code, list1 (obj)); 1498 signal_error (Qinvalid_byte_code, list1 (obj));
1506 } 1499 }
1612 static void 1605 static void
1613 optimize_byte_code (/* in */ 1606 optimize_byte_code (/* in */
1614 Lisp_Object instructions, 1607 Lisp_Object instructions,
1615 Lisp_Object constants, 1608 Lisp_Object constants,
1616 /* out */ 1609 /* out */
1617 Opbyte * CONST program, 1610 Opbyte * const program,
1618 int * CONST program_length, 1611 int * const program_length,
1619 int * CONST varbind_count) 1612 int * const varbind_count)
1620 { 1613 {
1621 size_t instructions_length = XSTRING_LENGTH (instructions); 1614 size_t instructions_length = XSTRING_LENGTH (instructions);
1622 size_t comfy_size = 2 * instructions_length; 1615 size_t comfy_size = 2 * instructions_length;
1623 1616
1624 int * CONST icounts = alloca_array (int, comfy_size); 1617 int * const icounts = alloca_array (int, comfy_size);
1625 int * icounts_ptr = icounts; 1618 int * icounts_ptr = icounts;
1626 1619
1627 /* We maintain a table of jumps in the source code. */ 1620 /* We maintain a table of jumps in the source code. */
1628 struct jump 1621 struct jump
1629 { 1622 {
1630 int from; 1623 int from;
1631 int to; 1624 int to;
1632 }; 1625 };
1633 struct jump * CONST jumps = alloca_array (struct jump, comfy_size); 1626 struct jump * const jumps = alloca_array (struct jump, comfy_size);
1634 struct jump *jumps_ptr = jumps; 1627 struct jump *jumps_ptr = jumps;
1635 1628
1636 Opbyte *program_ptr = program; 1629 Opbyte *program_ptr = program;
1637 1630
1638 CONST Bufbyte *ptr = XSTRING_DATA (instructions); 1631 const Bufbyte *ptr = XSTRING_DATA (instructions);
1639 CONST Bufbyte * CONST end = ptr + instructions_length; 1632 const Bufbyte * const end = ptr + instructions_length;
1640 1633
1641 *varbind_count = 0; 1634 *varbind_count = 0;
1642 1635
1643 while (ptr < end) 1636 while (ptr < end)
1644 { 1637 {
1899 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions)); 1892 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
1900 optimize_byte_code (f->instructions, f->constants, 1893 optimize_byte_code (f->instructions, f->constants,
1901 program, &program_length, &varbind_count); 1894 program, &program_length, &varbind_count);
1902 f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count; 1895 f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count;
1903 f->instructions = 1896 f->instructions =
1904 Fpurecopy (make_opaque (program_length * sizeof (Opbyte), 1897 make_opaque (program, program_length * sizeof (Opbyte));
1905 (CONST void *) program));
1906 } 1898 }
1907 1899
1908 assert (OPAQUEP (f->instructions)); 1900 assert (OPAQUEP (f->instructions));
1909 } 1901 }
1910 1902
1986 write_c_string (print_readably ? "]" : ">", printcharfun); 1978 write_c_string (print_readably ? "]" : ">", printcharfun);
1987 } 1979 }
1988 1980
1989 1981
1990 static Lisp_Object 1982 static Lisp_Object
1991 mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object)) 1983 mark_compiled_function (Lisp_Object obj)
1992 { 1984 {
1993 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); 1985 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
1994 1986
1995 markobj (f->instructions); 1987 mark_object (f->instructions);
1996 markobj (f->arglist); 1988 mark_object (f->arglist);
1997 markobj (f->doc_and_interactive); 1989 mark_object (f->doc_and_interactive);
1998 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK 1990 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1999 markobj (f->annotated); 1991 mark_object (f->annotated);
2000 #endif 1992 #endif
2001 /* tail-recurse on constants */ 1993 /* tail-recurse on constants */
2002 return f->constants; 1994 return f->constants;
2003 } 1995 }
2004 1996
2028 f->flags.domainp, 2020 f->flags.domainp,
2029 internal_hash (f->instructions, depth + 1), 2021 internal_hash (f->instructions, depth + 1),
2030 internal_hash (f->constants, depth + 1)); 2022 internal_hash (f->constants, depth + 1));
2031 } 2023 }
2032 2024
2025 static const struct lrecord_description compiled_function_description[] = {
2026 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) },
2027 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) },
2028 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) },
2029 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) },
2030 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2031 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) },
2032 #endif
2033 { XD_END }
2034 };
2035
2033 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function, 2036 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
2034 mark_compiled_function, 2037 mark_compiled_function,
2035 print_compiled_function, 0, 2038 print_compiled_function, 0,
2036 compiled_function_equal, 2039 compiled_function_equal,
2037 compiled_function_hash, 2040 compiled_function_hash,
2041 compiled_function_description,
2038 Lisp_Compiled_Function); 2042 Lisp_Compiled_Function);
2039 2043
2040 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /* 2044 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
2041 Return t if OBJECT is a byte-compiled function object. 2045 Return t if OBJECT is a byte-compiled function object.
2042 */ 2046 */
2063 2067
2064 { 2068 {
2065 /* Invert action performed by optimize_byte_code() */ 2069 /* Invert action performed by optimize_byte_code() */
2066 Lisp_Opaque *opaque = XOPAQUE (f->instructions); 2070 Lisp_Opaque *opaque = XOPAQUE (f->instructions);
2067 2071
2068 Bufbyte * CONST buffer = 2072 Bufbyte * const buffer =
2069 alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN); 2073 alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
2070 Bufbyte *bp = buffer; 2074 Bufbyte *bp = buffer;
2071 2075
2072 CONST Opbyte * CONST program = (CONST Opbyte *) OPAQUE_DATA (opaque); 2076 const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque);
2073 CONST Opbyte *program_ptr = program; 2077 const Opbyte *program_ptr = program;
2074 CONST Opbyte * CONST program_end = program_ptr + OPAQUE_SIZE (opaque); 2078 const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque);
2075 2079
2076 while (program_ptr < program_end) 2080 while (program_ptr < program_end)
2077 { 2081 {
2078 Opcode opcode = (Opcode) READ_UINT_1; 2082 Opcode opcode = (Opcode) READ_UINT_1;
2079 bp += set_charptr_emchar (bp, opcode); 2083 bp += set_charptr_emchar (bp, opcode);
2346 if (!CONSP (tem)) 2350 if (!CONSP (tem))
2347 signal_simple_error ("Invalid lazy-loaded byte code", tem); 2351 signal_simple_error ("Invalid lazy-loaded byte code", tem);
2348 /* v18 or v19 bytecode file. Need to Ebolify. */ 2352 /* v18 or v19 bytecode file. Need to Ebolify. */
2349 if (f->flags.ebolified && VECTORP (XCDR (tem))) 2353 if (f->flags.ebolified && VECTORP (XCDR (tem)))
2350 ebolify_bytecode_constants (XCDR (tem)); 2354 ebolify_bytecode_constants (XCDR (tem));
2351 /* VERY IMPORTANT to purecopy here!!!!! 2355 f->instructions = XCAR (tem);
2352 See load_force_doc_string_unwind. */ 2356 f->constants = XCDR (tem);
2353 f->instructions = Fpurecopy (XCAR (tem));
2354 f->constants = Fpurecopy (XCDR (tem));
2355 return function; 2357 return function;
2356 } 2358 }
2357 abort (); 2359 abort ();
2358 return Qnil; /* not reached */ 2360 return Qnil; /* not reached */
2359 } 2361 }