Mercurial > hg > xemacs-beta

comparison src/bytecode.c @ 563:183866b06e0b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2001-05-24 07:50:48 by ben] Makefile.in.in, abbrev.c, alloc.c, buffer.c, bytecode.c, callint.c, callproc.c, casetab.c, chartab.c, cmdloop.c, cmds.c, console-msw.c, console-msw.h, console-stream.c, console-tty.c, console-x.c, console.c, data.c, database.c, debug.c, device-gtk.c, device-msw.c, device-tty.c, device-x.c, device.c, dialog-gtk.c, dialog-msw.c, dialog-x.c, dialog.c, dired-msw.c, dired.c, doc.c, doprnt.c, dragdrop.c, editfns.c, eldap.c, eldap.h, elhash.c, emacs-widget-accessors.c, emacs.c, emodules.c, esd.c, eval.c, event-Xt.c, event-gtk.c, event-msw.c, event-stream.c, events.c, extents.c, faces.c, file-coding.c, fileio.c, filelock.c, floatfns.c, fns.c, font-lock.c, frame-gtk.c, frame-x.c, frame.c, general-slots.h, glade.c, glyphs-gtk.c, glyphs-msw.c, glyphs-widget.c, glyphs-x.c, glyphs.c, glyphs.h, gpmevent.c, gui-gtk.c, gui-x.c, gui.c, gutter.c, hpplay.c, indent.c, input-method-xlib.c, insdel.c, intl.c, keymap.c, libsst.c, libsst.h, linuxplay.c, lisp.h, lread.c, lstream.c, lstream.h, macros.c, marker.c, md5.c, menubar-gtk.c, menubar-msw.c, menubar-x.c, menubar.c, minibuf.c, miscplay.c, miscplay.h, mule-ccl.c, mule-charset.c, mule-wnnfns.c, mule.c, nas.c, ntplay.c, ntproc.c, objects-gtk.c, objects-msw.c, objects-x.c, objects.c, postgresql.c, print.c, process-nt.c, process-unix.c, process.c, ralloc.c, rangetab.c, redisplay.c, scrollbar.c, search.c, select-gtk.c, select-x.c, select.c, sgiplay.c, sheap.c, sound.c, specifier.c, sunplay.c, symbols.c, symeval.h, symsinit.h, syntax.c, sysdep.c, toolbar-msw.c, toolbar.c, tooltalk.c, ui-byhand.c, ui-gtk.c, undo.c, unexaix.c, unexapollo.c, unexconvex.c, unexec.c, widget.c, win32.c, window.c: -- defsymbol -> DEFSYMBOL. -- add an error type to all errors. -- eliminate the error functions in eval.c that let you just use Qerror as the type. -- redo the error API to be more consistent, sensibly named, and easier to use. -- redo the error hierarchy somewhat. create new errors: structure-formation-error, gui-error, invalid-constant, stack-overflow, out-of-memory, process-error, network-error, sound-error, printing-unreadable-object, base64-conversion- error; coding-system-error renamed to text-conversion error; some others. -- fix Mule problems in error strings in emodules.c, tooltalk.c. -- fix error handling in mswin open-network-stream. -- Mule-ize all sound files and clean up the headers. -- nativesound.h -> sound.h and used for all sound files. -- move some shared stuff into glyphs-shared.c: first attempt at eliminating some of the massive GTK code duplication. xemacs.mak: add glyphs-shared.c. xemacs-faq.texi: document how to debug X errors subr.el: fix doc string to reflect reality
author ben
date Thu, 24 May 2001 07:51:33 +0000
parents 576fb035e263
children 13e3d7ae7155
comparison
equal deleted inserted replaced
562:c775bd016b32 563:183866b06e0b
209 }; 209 };
210 typedef enum Opcode Opcode; 210 typedef enum Opcode Opcode;
211 typedef unsigned char Opbyte; 211 typedef unsigned char Opbyte;
212 212
213 213
214 static void invalid_byte_code_error (char *error_message, ...);
215
216 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr, 214 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
217 const Opbyte *program_ptr, 215 const Opbyte *program_ptr,
218 Opcode opcode); 216 Opcode opcode);
219 217
220 static Lisp_Object execute_optimized_program (const Opbyte *program, 218 static Lisp_Object execute_optimized_program (const Opbyte *program,
632 while (1) 630 while (1)
633 { 631 {
634 REGISTER Opcode opcode = (Opcode) READ_UINT_1; 632 REGISTER Opcode opcode = (Opcode) READ_UINT_1;
635 #ifdef ERROR_CHECK_BYTE_CODE 633 #ifdef ERROR_CHECK_BYTE_CODE
636 if (stack_ptr > stack_end) 634 if (stack_ptr > stack_end)
637 invalid_byte_code_error ("byte code stack overflow"); 635 stack_overflow ("byte code stack overflow", Qunbound);
638 if (stack_ptr < stack_beg) 636 if (stack_ptr < stack_beg)
639 invalid_byte_code_error ("byte code stack underflow"); 637 stack_overflow ("byte code stack underflow", Qunbound);
640 #endif 638 #endif
641 639
642 #ifdef BYTE_CODE_METER 640 #ifdef BYTE_CODE_METER
643 prev_opcode = this_opcode; 641 prev_opcode = this_opcode;
644 this_opcode = opcode; 642 this_opcode = opcode;
840 case Breturn: 838 case Breturn:
841 UNGCPRO; 839 UNGCPRO;
842 #ifdef ERROR_CHECK_BYTE_CODE 840 #ifdef ERROR_CHECK_BYTE_CODE
843 /* Binds and unbinds are supposed to be compiled balanced. */ 841 /* Binds and unbinds are supposed to be compiled balanced. */
844 if (specpdl_depth() != speccount) 842 if (specpdl_depth() != speccount)
845 invalid_byte_code_error ("unbalanced specbinding stack"); 843 invalid_byte_code ("unbalanced specbinding stack", Qunbound);
846 #endif 844 #endif
847 return TOP; 845 return TOP;
848 846
849 case Bdiscard: 847 case Bdiscard:
850 DISCARD (1); 848 DISCARD (1);
1479 } 1477 }
1480 return stack_ptr; 1478 return stack_ptr;
1481 } 1479 }
1482 1480
1483 1481
1484 static void 1482 DOESNT_RETURN
1485 invalid_byte_code_error (char *error_message, ...) 1483 invalid_byte_code (const char *reason, Lisp_Object frob)
1486 { 1484 {
1487 Lisp_Object obj; 1485 signal_error (Qinvalid_byte_code, reason, frob);
1488 va_list args;
1489 char *buf = alloca_array (char, strlen (error_message) + 128);
1490
1491 sprintf (buf, "%s", error_message);
1492 va_start (args, error_message);
1493 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (buf), Qnil, -1,
1494 args);
1495 va_end (args);
1496
1497 signal_error (Qinvalid_byte_code, list1 (obj));
1498 } 1486 }
1499 1487
1500 /* Check for valid opcodes. Change this when adding new opcodes. */ 1488 /* Check for valid opcodes. Change this when adding new opcodes. */
1501 static void 1489 static void
1502 check_opcode (Opcode opcode) 1490 check_opcode (Opcode opcode)
1503 { 1491 {
1504 if ((opcode < Bvarref) || 1492 if ((opcode < Bvarref) ||
1505 (opcode == 0251) || 1493 (opcode == 0251) ||
1506 (opcode > Bassq && opcode < Bconstant)) 1494 (opcode > Bassq && opcode < Bconstant))
1507 invalid_byte_code_error 1495 invalid_byte_code ("invalid opcode in instruction stream",
1508 ("invalid opcode %d in instruction stream", opcode); 1496 make_int (opcode));
1509 } 1497 }
1510 1498
1511 /* Check that IDX is a valid offset into the `constants' vector */ 1499 /* Check that IDX is a valid offset into the `constants' vector */
1512 static void 1500 static void
1513 check_constants_index (int idx, Lisp_Object constants) 1501 check_constants_index (int idx, Lisp_Object constants)
1514 { 1502 {
1515 if (idx < 0 || idx >= XVECTOR_LENGTH (constants)) 1503 if (idx < 0 || idx >= XVECTOR_LENGTH (constants))
1516 invalid_byte_code_error 1504 signal_ferror
1517 ("reference %d to constants array out of range 0, %d", 1505 (Qinvalid_byte_code,
1506 "reference %d to constants array out of range 0, %ld",
1518 idx, XVECTOR_LENGTH (constants) - 1); 1507 idx, XVECTOR_LENGTH (constants) - 1);
1519 } 1508 }
1520 1509
1521 /* Get next character from Lisp instructions string. */ 1510 /* Get next character from Lisp instructions string. */
1522 #define READ_INSTRUCTION_CHAR(lvalue) do { \ 1511 #define READ_INSTRUCTION_CHAR(lvalue) do { \
1523 (lvalue) = charptr_emchar (ptr); \ 1512 (lvalue) = charptr_emchar (ptr); \
1524 INC_CHARPTR (ptr); \ 1513 INC_CHARPTR (ptr); \
1525 *icounts_ptr++ = program_ptr - program; \ 1514 *icounts_ptr++ = program_ptr - program; \
1526 if (lvalue > UCHAR_MAX) \ 1515 if (lvalue > UCHAR_MAX) \
1527 invalid_byte_code_error \ 1516 invalid_byte_code \
1528 ("Invalid character %c in byte code string"); \ 1517 ("Invalid character in byte code string", make_char (lvalue)); \
1529 } while (0) 1518 } while (0)
1530 1519
1531 /* Get opcode from Lisp instructions string. */ 1520 /* Get opcode from Lisp instructions string. */
1532 #define READ_OPCODE do { \ 1521 #define READ_OPCODE do { \
1533 unsigned int c; \ 1522 unsigned int c; \
1651 arg = opcode - Bvarref; 1640 arg = opcode - Bvarref;
1652 do_varref: 1641 do_varref:
1653 check_constants_index (arg, constants); 1642 check_constants_index (arg, constants);
1654 val = XVECTOR_DATA (constants) [arg]; 1643 val = XVECTOR_DATA (constants) [arg];
1655 if (!SYMBOLP (val)) 1644 if (!SYMBOLP (val))
1656 invalid_byte_code_error ("variable reference to non-symbol %S", val); 1645 invalid_byte_code ("variable reference to non-symbol", val);
1657 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val))) 1646 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1658 invalid_byte_code_error ("variable reference to constant symbol %s", 1647 invalid_byte_code ("variable reference to constant symbol", val);
1659 string_data (XSYMBOL (val)->name));
1660 WRITE_NARGS (Bvarref); 1648 WRITE_NARGS (Bvarref);
1661 break; 1649 break;
1662 1650
1663 case Bvarset+7: READ_OPERAND_2; goto do_varset; 1651 case Bvarset+7: READ_OPERAND_2; goto do_varset;
1664 case Bvarset+6: READ_OPERAND_1; goto do_varset; 1652 case Bvarset+6: READ_OPERAND_1; goto do_varset;
1667 arg = opcode - Bvarset; 1655 arg = opcode - Bvarset;
1668 do_varset: 1656 do_varset:
1669 check_constants_index (arg, constants); 1657 check_constants_index (arg, constants);
1670 val = XVECTOR_DATA (constants) [arg]; 1658 val = XVECTOR_DATA (constants) [arg];
1671 if (!SYMBOLP (val)) 1659 if (!SYMBOLP (val))
1672 invalid_byte_code_error ("attempt to set non-symbol %S", val); 1660 wtaerror ("attempt to set non-symbol", val);
1673 if (EQ (val, Qnil) || EQ (val, Qt)) 1661 if (EQ (val, Qnil) || EQ (val, Qt))
1674 invalid_byte_code_error ("attempt to set constant symbol %s", 1662 signal_error (Qsetting_constant, 0, val);
1675 string_data (XSYMBOL (val)->name));
1676 /* Ignore assignments to keywords by converting to Bdiscard. 1663 /* Ignore assignments to keywords by converting to Bdiscard.
1677 For backward compatibility only - we'd like to make this an error. */ 1664 For backward compatibility only - we'd like to make this an error. */
1678 if (SYMBOL_IS_KEYWORD (val)) 1665 if (SYMBOL_IS_KEYWORD (val))
1679 REWRITE_OPCODE (Bdiscard); 1666 REWRITE_OPCODE (Bdiscard);
1680 else 1667 else
1689 do_varbind: 1676 do_varbind:
1690 (*varbind_count)++; 1677 (*varbind_count)++;
1691 check_constants_index (arg, constants); 1678 check_constants_index (arg, constants);
1692 val = XVECTOR_DATA (constants) [arg]; 1679 val = XVECTOR_DATA (constants) [arg];
1693 if (!SYMBOLP (val)) 1680 if (!SYMBOLP (val))
1694 invalid_byte_code_error ("attempt to let-bind non-symbol %S", val); 1681 wtaerror ("attempt to let-bind non-symbol", val);
1695 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val))) 1682 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1696 invalid_byte_code_error ("attempt to let-bind constant symbol %s", 1683 signal_error (Qsetting_constant,
1697 string_data (XSYMBOL (val)->name)); 1684 "attempt to let-bind constant symbol", val);
1698 WRITE_NARGS (Bvarbind); 1685 WRITE_NARGS (Bvarbind);
1699 break; 1686 break;
1700 1687
1701 case Bcall+7: READ_OPERAND_2; goto do_call; 1688 case Bcall+7: READ_OPERAND_2; goto do_call;
1702 case Bcall+6: READ_OPERAND_1; goto do_call; 1689 case Bcall+6: READ_OPERAND_1; goto do_call;
1738 /* Record program-relative goto addresses in `jumps' table */ 1725 /* Record program-relative goto addresses in `jumps' table */
1739 jumps_ptr->from = icounts_ptr - icounts - argsize; 1726 jumps_ptr->from = icounts_ptr - icounts - argsize;
1740 jumps_ptr->to = jumps_ptr->from + arg; 1727 jumps_ptr->to = jumps_ptr->from + arg;
1741 jumps_ptr++; 1728 jumps_ptr++;
1742 if (arg >= -1 && arg <= argsize) 1729 if (arg >= -1 && arg <= argsize)
1743 invalid_byte_code_error 1730 invalid_byte_code ("goto instruction is its own target", Qunbound);
1744 ("goto instruction is its own target");
1745 if (arg <= SCHAR_MIN || 1731 if (arg <= SCHAR_MIN ||
1746 arg > SCHAR_MAX) 1732 arg > SCHAR_MAX)
1747 { 1733 {
1748 if (argsize == 1) 1734 if (argsize == 1)
1749 REWRITE_OPCODE (opcode + Bgoto - BRgoto); 1735 REWRITE_OPCODE (opcode + Bgoto - BRgoto);
2345 2331
2346 if (CONSP (f->instructions)) 2332 if (CONSP (f->instructions))
2347 { 2333 {
2348 Lisp_Object tem = read_doc_string (f->instructions); 2334 Lisp_Object tem = read_doc_string (f->instructions);
2349 if (!CONSP (tem)) 2335 if (!CONSP (tem))
2350 signal_simple_error ("Invalid lazy-loaded byte code", tem); 2336 signal_error (Qinvalid_byte_code,
2337 "Invalid lazy-loaded byte code", tem);
2351 /* v18 or v19 bytecode file. Need to Ebolify. */ 2338 /* v18 or v19 bytecode file. Need to Ebolify. */
2352 if (f->flags.ebolified && VECTORP (XCDR (tem))) 2339 if (f->flags.ebolified && VECTORP (XCDR (tem)))
2353 ebolify_bytecode_constants (XCDR (tem)); 2340 ebolify_bytecode_constants (XCDR (tem));
2354 f->instructions = XCAR (tem); 2341 f->instructions = XCAR (tem);
2355 f->constants = XCDR (tem); 2342 f->constants = XCDR (tem);
2410 syms_of_bytecode (void) 2397 syms_of_bytecode (void)
2411 { 2398 {
2412 INIT_LRECORD_IMPLEMENTATION (compiled_function); 2399 INIT_LRECORD_IMPLEMENTATION (compiled_function);
2413 2400
2414 DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state); 2401 DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state);
2415 defsymbol (&Qbyte_code, "byte-code"); 2402 DEFSYMBOL (Qbyte_code);
2416 defsymbol (&Qcompiled_functionp, "compiled-function-p"); 2403 DEFSYMBOL_MULTIWORD_PREDICATE (Qcompiled_functionp);
2417 2404
2418 DEFSUBR (Fbyte_code); 2405 DEFSUBR (Fbyte_code);
2419 DEFSUBR (Ffetch_bytecode); 2406 DEFSUBR (Ffetch_bytecode);
2420 DEFSUBR (Foptimize_compiled_function); 2407 DEFSUBR (Foptimize_compiled_function);
2421 2408
2430 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK 2417 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2431 DEFSUBR (Fcompiled_function_annotation); 2418 DEFSUBR (Fcompiled_function_annotation);
2432 #endif 2419 #endif
2433 2420
2434 #ifdef BYTE_CODE_METER 2421 #ifdef BYTE_CODE_METER
2435 defsymbol (&Qbyte_code_meter, "byte-code-meter"); 2422 DEFSYMBOL (Qbyte_code_meter);
2436 #endif 2423 #endif
2437 } 2424 }
2438 2425
2439 void 2426 void
2440 vars_of_bytecode (void) 2427 vars_of_bytecode (void)