annotate src/bytecode.c @ 4885:6772ce4d982b

Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums lisp/ChangeLog addition: 2010-01-24 Aidan Kehoe <kehoea@parhasard.net> Correct the semantics of #'member*, #'eql, #'assoc* in the presence of bignums; change the integerp byte code to fixnump semantics. * bytecomp.el (fixnump, integerp, byte-compile-integerp): Change the integerp byte code to fixnump; add a byte-compile method to integerp using fixnump and numberp and avoiding a funcall most of the time, since in the non-core contexts where integerp is used, it's mostly distinguishing between fixnums and things that are not numbers at all. * byte-optimize.el (side-effect-free-fns, byte-after-unbind-ops) (byte-compile-side-effect-and-error-free-ops): Replace the integerp bytecode with fixnump; add fixnump to the side-effect-free-fns. Add the other extended number type predicates to the list in passing. * obsolete.el (floatp-safe): Mark this as obsolete. * cl.el (eql): Go into more detail in the docstring here. Don't bother checking whether both arguments are numbers; one is enough, #'equal will fail correctly if they have distinct types. (subst): Replace a call to #'integerp (deciding whether to use #'memq or not) with one to #'fixnump. Delete most-positive-fixnum, most-negative-fixnum from this file; they're now always in C, so they can't be modified from Lisp. * cl-seq.el (member*, assoc*, rassoc*): Correct these functions in the presence of bignums. * cl-macs.el (cl-make-type-test): The type test for a fixnum is now fixnump. Ditch floatp-safe, use floatp instead. (eql): Correct this compiler macro in the presence of bignums. (assoc*): Correct this compiler macro in the presence of bignums. * simple.el (undo): Change #'integerp to #'fixnump here, since we use #'delq with the same value as ELT a few lines down. src/ChangeLog addition: 2010-01-24 Aidan Kehoe <kehoea@parhasard.net> Fix problems with #'eql, extended number types, and the hash table implementation; change the Bintegerp bytecode to fixnump semantics even on bignum builds, since #'integerp can have a fast implementation in terms of #'fixnump for most of its extant uses, but not vice-versa. * lisp.h: Always #include number.h; we want the macros provided in it, even if the various number types are not available. * number.h (NON_FIXNUM_NUMBER_P): New macro, giving 1 when its argument is of non-immediate number type. Equivalent to FLOATP if WITH_NUMBER_TYPES is not defined. * elhash.c (lisp_object_eql_equal, lisp_object_eql_hash): Use NON_FIXNUM_NUMBER_P in these functions, instead of FLOATP, giving more correct behaviour in the presence of the extended number types. * bytecode.c (Bfixnump, execute_optimized_program): Rename Bintegerp to Bfixnump; change its semantics to reflect the new name on builds with bignum support. * data.c (Ffixnump, Fintegerp, syms_of_data, vars_of_data): Always make #'fixnump available, even on non-BIGNUM builds; always implement #'integerp in this file, even on BIGNUM builds. Move most-positive-fixnum, most-negative-fixnum here from number.c, so they are Lisp constants even on builds without number types, and attempts to change or bind them error. Use the NUMBERP and INTEGERP macros even on builds without extended number types. * data.c (fixnum_char_or_marker_to_int): Rename this function from integer_char_or_marker_to_int, to better reflect the arguments it accepts. * number.c (Fevenp, Foddp, syms_of_number): Never provide #'integerp in this file. Remove #'oddp, #'evenp; their implementations are overridden by those in cl.el. * number.c (vars_of_number): most-positive-fixnum, most-negative-fixnum are no longer here. man/ChangeLog addition: 2010-01-23 Aidan Kehoe <kehoea@parhasard.net> Generally: be careful to say fixnum, not integer, when talking about fixed-precision integral types. I'm sure I've missed instances, both here and in the docstrings, but this is a decent start. * lispref/text.texi (Columns): Document where only fixnums, not integers generally, are accepted. (Registers): Remove some ancient char-int confoundance here. * lispref/strings.texi (Creating Strings, Creating Strings): Be more exact in describing where fixnums but not integers in general are accepted. (Creating Strings): Use a more contemporary example to illustrate how concat deals with lists including integers about #xFF. Delete some obsolete documentation on same. (Char Table Types): Document that only fixnums are accepted as values in syntax tables. * lispref/searching.texi (String Search, Search and Replace): Be exact in describing where fixnums but not integers in general are accepted. * lispref/range-tables.texi (Range Tables): Be exact in describing them; only fixnums are accepted to describe ranges. * lispref/os.texi (Killing XEmacs, User Identification) (Time of Day, Time Conversion): Be more exact about using fixnum where only fixed-precision integers are accepted. * lispref/objects.texi (Integer Type): Be more exact (and up-to-date) about the possible values for integers. Cross-reference to documentation of the bignum extension. (Equality Predicates): (Range Table Type): (Array Type): Use fixnum, not integer, to describe a fixed-precision integer. (Syntax Table Type): Correct some English syntax here. * lispref/numbers.texi (Numbers): Change the phrasing here to use fixnum to mean the fixed-precision integers normal in emacs. Document that our terminology deviates from that of Common Lisp, and that we're working on it. (Compatibility Issues): Reiterate the Common Lisp versus Emacs Lisp compatibility issues. (Comparison of Numbers, Arithmetic Operations): * lispref/commands.texi (Command Loop Info, Working With Events): * lispref/buffers.texi (Modification Time): Be more exact in describing where fixnums but not integers in general are accepted.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 24 Jan 2010 15:21:27 +0000
parents 1d61580e0cf7
children 6ef8256a020a db2db229ee82
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 /* Execution of byte code produced by bytecomp.el.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2 Implementation of compiled-function objects.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3 Copyright (C) 1992, 1993 Free Software Foundation, Inc.
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4 Copyright (C) 1995, 2002 Ben Wing.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 under the terms of the GNU General Public License as published by the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 Free Software Foundation; either version 2, or (at your option) any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16 for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 along with XEmacs; see the file COPYING. If not, write to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21 Boston, MA 02111-1307, USA. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 /* Synched up with: Mule 2.0, FSF 19.30. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25 /* This file has been Mule-ized. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28 /* Authorship:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30 FSF: long ago.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32 hacked on by jwz@jwz.org 1991-06
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 o added a compile-time switch to turn on simple sanity checking;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
34 o put back the obsolete byte-codes for error-detection;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35 o added a new instruction, unbind_all, which I will use for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36 tail-recursion elimination;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 o made temp_output_buffer_show be called with the right number
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38 of args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
39 o made the new bytecodes be called with args in the right order;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
40 o added metering support.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 by Hallvard:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43 o added relative jump instructions;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44 o all conditionals now only do QUIT if they jump.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 Ben Wing: some changes for Mule, 1995-06.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 Martin Buchholz: performance hacking, 1998-09.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 See Internals Manual, Evaluation.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52 #include <config.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 #include "lisp.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 #include "backtrace.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55 #include "buffer.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 #include "bytecode.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 #include "opaque.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 #include "syntax.h"
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
59 #include "window.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
61 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
62 static Lisp_Object
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
63 make_compiled_function_args (int totalargs)
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
64 {
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
65 Lisp_Compiled_Function_Args *args;
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
66 args = (Lisp_Compiled_Function_Args *)
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
67 alloc_lrecord
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
68 (FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args,
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
69 Lisp_Object, args, totalargs),
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
70 &lrecord_compiled_function_args);
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
71 args->size = totalargs;
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
72 return wrap_compiled_function_args (args);
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
73 }
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
74
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
75 static Bytecount
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
76 size_compiled_function_args (const void *lheader)
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
77 {
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
78 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args,
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
79 Lisp_Object, args,
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
80 ((Lisp_Compiled_Function_Args *)
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
81 lheader)->size);
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
82 }
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
83
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
84 static const struct memory_description compiled_function_args_description[] = {
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
85 { XD_LONG, offsetof (Lisp_Compiled_Function_Args, size) },
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
86 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Compiled_Function_Args, args),
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
87 XD_INDIRECT(0, 0) },
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
88 { XD_END }
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
89 };
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
90
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
91 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("compiled-function-args",
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
92 compiled_function_args,
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
93 1, /*dumpable-flag*/
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
94 0, 0, 0, 0, 0,
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
95 compiled_function_args_description,
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
96 size_compiled_function_args,
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
97 Lisp_Compiled_Function_Args);
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
98 #endif /* NEW_GC */
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
99
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 EXFUN (Ffetch_bytecode, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 enum Opcode /* Byte codes */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 Bvarref = 010,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 Bvarset = 020,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 Bvarbind = 030,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 Bcall = 040,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 Bunbind = 050,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 Bnth = 070,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 Bsymbolp = 071,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 Bconsp = 072,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 Bstringp = 073,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 Blistp = 074,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 Bold_eq = 075,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 Bold_memq = 076,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119 Bnot = 077,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120 Bcar = 0100,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 Bcdr = 0101,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122 Bcons = 0102,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123 Blist1 = 0103,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 Blist2 = 0104,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 Blist3 = 0105,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 Blist4 = 0106,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 Blength = 0107,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 Baref = 0110,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 Baset = 0111,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 Bsymbol_value = 0112,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 Bsymbol_function = 0113,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 Bset = 0114,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133 Bfset = 0115,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
134 Bget = 0116,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135 Bsubstring = 0117,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136 Bconcat2 = 0120,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 Bconcat3 = 0121,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 Bconcat4 = 0122,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 Bsub1 = 0123,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 Badd1 = 0124,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 Beqlsign = 0125,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 Bgtr = 0126,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 Blss = 0127,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144 Bleq = 0130,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 Bgeq = 0131,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146 Bdiff = 0132,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 Bnegate = 0133,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 Bplus = 0134,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 Bmax = 0135,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 Bmin = 0136,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 Bmult = 0137,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 Bpoint = 0140,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 Beq = 0141, /* was Bmark,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155 but no longer generated as of v18 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
156 Bgoto_char = 0142,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 Binsert = 0143,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 Bpoint_max = 0144,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 Bpoint_min = 0145,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 Bchar_after = 0146,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 Bfollowing_char = 0147,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 Bpreceding_char = 0150,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 Bcurrent_column = 0151,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 Bindent_to = 0152,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165 Bequal = 0153, /* was Bscan_buffer,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 but no longer generated as of v18 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167 Beolp = 0154,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 Beobp = 0155,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 Bbolp = 0156,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170 Bbobp = 0157,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 Bcurrent_buffer = 0160,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 Bset_buffer = 0161,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173 Bsave_current_buffer = 0162, /* was Bread_char,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174 but no longer generated as of v19 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 Bmemq = 0163, /* was Bset_mark,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 but no longer generated as of v18 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 Binteractive_p = 0164, /* Needed since interactive-p takes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 unevalled args */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 Bforward_char = 0165,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 Bforward_word = 0166,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 Bskip_chars_forward = 0167,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 Bskip_chars_backward = 0170,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183 Bforward_line = 0171,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184 Bchar_syntax = 0172,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 Bbuffer_substring = 0173,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186 Bdelete_region = 0174,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 Bnarrow_to_region = 0175,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188 Bwiden = 0176,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189 Bend_of_line = 0177,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 Bconstant2 = 0201,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192 Bgoto = 0202,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 Bgotoifnil = 0203,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 Bgotoifnonnil = 0204,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 Bgotoifnilelsepop = 0205,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 Bgotoifnonnilelsepop = 0206,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 Breturn = 0207,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198 Bdiscard = 0210,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 Bdup = 0211,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
201 Bsave_excursion = 0212,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 Bsave_window_excursion= 0213,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203 Bsave_restriction = 0214,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 Bcatch = 0215,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 Bunwind_protect = 0216,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 Bcondition_case = 0217,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 Btemp_output_buffer_setup = 0220,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 Btemp_output_buffer_show = 0221,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 Bunbind_all = 0222,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213 Bset_marker = 0223,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 Bmatch_beginning = 0224,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 Bmatch_end = 0225,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216 Bupcase = 0226,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217 Bdowncase = 0227,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 Bstring_equal = 0230,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 Bstring_lessp = 0231,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 Bold_equal = 0232,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 Bnthcdr = 0233,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 Belt = 0234,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224 Bold_member = 0235,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
225 Bold_assq = 0236,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 Bnreverse = 0237,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 Bsetcar = 0240,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 Bsetcdr = 0241,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 Bcar_safe = 0242,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 Bcdr_safe = 0243,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 Bnconc = 0244,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232 Bquo = 0245,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 Brem = 0246,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 Bnumberp = 0247,
4885
6772ce4d982b Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents: 4775
diff changeset
235 Bfixnump = 0250, /* Was Bintegerp. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 BRgoto = 0252,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 BRgotoifnil = 0253,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 BRgotoifnonnil = 0254,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 BRgotoifnilelsepop = 0255,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 BRgotoifnonnilelsepop = 0256,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 BlistN = 0257,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 BconcatN = 0260,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 BinsertN = 0261,
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
246
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
247 Bbind_multiple_value_limits = 0262, /* New in 21.5. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
248 Bmultiple_value_list_internal = 0263, /* New in 21.5. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
249 Bmultiple_value_call = 0264, /* New in 21.5. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
250 Bthrow = 0265, /* New in 21.5. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
251
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 Bmember = 0266, /* new in v20 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 Bassq = 0267, /* new in v20 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 Bconstant = 0300
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 typedef enum Opcode Opcode;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
261 const Opbyte *program_ptr,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 Opcode opcode);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 /* #define BYTE_CODE_METER */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 #ifdef BYTE_CODE_METER
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
272 int byte_metering_on;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 meter_code (Opcode prev_opcode, Opcode this_opcode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277 if (byte_metering_on)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279 Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280 p[0] = INT_PLUS1 (p[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281 if (prev_opcode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282 p[prev_opcode] = INT_PLUS1 (p[prev_opcode]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 #endif /* BYTE_CODE_METER */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290 bytecode_negate (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
294 if (INTP (obj)) return make_integer (- XINT (obj));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj));
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
296 if (CHARP (obj)) return make_integer (- ((int) XCHAR (obj)));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
297 if (MARKERP (obj)) return make_integer (- ((int) marker_position (obj)));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
298 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
299 if (BIGNUMP (obj)) BIGNUM_ARITH_RETURN (obj, neg);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
300 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
301 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
302 if (RATIOP (obj)) RATIO_ARITH_RETURN (obj, neg);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
303 #endif
4678
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4677
diff changeset
304 #ifdef HAVE_BIGFLOAT
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4677
diff changeset
305 if (BIGFLOATP (obj)) BIGFLOAT_ARITH_RETURN (obj, neg);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
306 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 bytecode_nreverse (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 REGISTER Lisp_Object prev = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 REGISTER Lisp_Object tail = list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 while (!NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 REGISTER Lisp_Object next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321 CHECK_CONS (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
322 next = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
323 XCDR (tail) = prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 prev = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 tail = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 return prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331 /* We have our own two-argument versions of various arithmetic ops.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 Only two-argument arithmetic operations have their own byte codes. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
336 #ifdef WITH_NUMBER_TYPES
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
337 switch (promote_args (&obj1, &obj2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
338 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
339 case FIXNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
340 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
341 EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
342 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
343 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
344 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
345 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
346 return bignum_cmp (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
347 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
348 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
349 case RATIO_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
350 return ratio_cmp (XRATIO_DATA (obj1), XRATIO_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
351 #endif
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
352 #ifdef HAVE_BIGFLOAT
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
353 case BIGFLOAT_T:
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
354 return bigfloat_cmp (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2));
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
355 #endif
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
356 default: /* FLOAT_T */
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
357 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
358 double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
359 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
360 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
361 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
362 #else /* !WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 EMACS_INT ival1, ival2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368 if (INTP (obj1)) ival1 = XINT (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 else goto arithcompare_float;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 if (INTP (obj2)) ival2 = XINT (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 else goto arithcompare_float;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 arithcompare_float:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 double dval1, dval2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386 if (FLOATP (obj1)) dval1 = XFLOAT_DATA (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387 else if (INTP (obj1)) dval1 = (double) XINT (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 else if (CHARP (obj1)) dval1 = (double) XCHAR (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 if (FLOATP (obj2)) dval2 = XFLOAT_DATA (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 else if (INTP (obj2)) dval2 = (double) XINT (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 else if (CHARP (obj2)) dval2 = (double) XCHAR (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
399 else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
408 #endif /* WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
414 #ifdef WITH_NUMBER_TYPES
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
415 switch (promote_args (&obj1, &obj2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
416 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
417 case FIXNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
418 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
419 EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
420 switch (opcode)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
421 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
422 case Bplus: ival1 += ival2; break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
423 case Bdiff: ival1 -= ival2; break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
424 case Bmult:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
425 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
426 /* Due to potential overflow, we compute using bignums */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
427 bignum_set_long (scratch_bignum, ival1);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
428 bignum_set_long (scratch_bignum2, ival2);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
429 bignum_mul (scratch_bignum, scratch_bignum, scratch_bignum2);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
430 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
431 #else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
432 ival1 *= ival2; break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
433 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
434 case Bquo:
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
435 if (ival2 == 0)
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
436 signal_error_2 (Qarith_error, "division by zero", obj1, obj2);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
437 ival1 /= ival2;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
438 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
439 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
440 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
441 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
442 return make_integer (ival1);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
443 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
444 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
445 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
446 switch (opcode)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
447 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
448 case Bplus:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
449 bignum_add (scratch_bignum, XBIGNUM_DATA (obj1),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
450 XBIGNUM_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
451 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
452 case Bdiff:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
453 bignum_sub (scratch_bignum, XBIGNUM_DATA (obj1),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
454 XBIGNUM_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
455 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
456 case Bmult:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
457 bignum_mul (scratch_bignum, XBIGNUM_DATA (obj1),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
458 XBIGNUM_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
459 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
460 case Bquo:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
461 if (bignum_sign (XBIGNUM_DATA (obj2)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
462 signal_error_2 (Qarith_error, "division by zero", obj1, obj2);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
463 bignum_div (scratch_bignum, XBIGNUM_DATA (obj1),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
464 XBIGNUM_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
465 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
466 case Bmax:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
467 return bignum_gt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
468 ? obj1 : obj2;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
469 case Bmin:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
470 return bignum_lt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
471 ? obj1 : obj2;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
472 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
473 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
474 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
475 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
476 case RATIO_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
477 switch (opcode)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
478 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
479 case Bplus:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
480 ratio_add (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
481 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
482 case Bdiff:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
483 ratio_sub (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
484 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
485 case Bmult:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
486 ratio_mul (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
487 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
488 case Bquo:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
489 if (ratio_sign (XRATIO_DATA (obj2)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
490 signal_error_2 (Qarith_error, "division by zero", obj1, obj2);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
491 ratio_div (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
492 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
493 case Bmax:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
494 return ratio_gt (XRATIO_DATA (obj1), XRATIO_DATA (obj2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
495 ? obj1 : obj2;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
496 case Bmin:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
497 return ratio_lt (XRATIO_DATA (obj1), XRATIO_DATA (obj2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
498 ? obj1 : obj2;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
499 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
500 return make_ratio_rt (scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
501 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
502 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
503 case BIGFLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
504 bigfloat_set_prec (scratch_bigfloat, max (XBIGFLOAT_GET_PREC (obj1),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
505 XBIGFLOAT_GET_PREC (obj2)));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
506 switch (opcode)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
507 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
508 case Bplus:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
509 bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (obj1),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
510 XBIGFLOAT_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
511 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
512 case Bdiff:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
513 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (obj1),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
514 XBIGFLOAT_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
515 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
516 case Bmult:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
517 bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (obj1),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
518 XBIGFLOAT_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
519 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
520 case Bquo:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
521 if (bigfloat_sign (XBIGFLOAT_DATA (obj2)) == 0)
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
522 signal_error_2 (Qarith_error, "division by zero", obj1, obj2);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
523 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (obj1),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
524 XBIGFLOAT_DATA (obj2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
525 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
526 case Bmax:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
527 return bigfloat_gt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
528 ? obj1 : obj2;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
529 case Bmin:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
530 return bigfloat_lt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
531 ? obj1 : obj2;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
532 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
533 return make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
534 #endif
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
535 default: /* FLOAT_T */
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
536 {
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
537 double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2);
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
538 switch (opcode)
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
539 {
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
540 case Bplus: dval1 += dval2; break;
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
541 case Bdiff: dval1 -= dval2; break;
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
542 case Bmult: dval1 *= dval2; break;
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
543 case Bquo:
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
544 if (dval2 == 0.0)
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
545 signal_error_2 (Qarith_error, "division by zero", obj1, obj2);
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
546 dval1 /= dval2;
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
547 break;
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
548 case Bmax: if (dval1 < dval2) dval1 = dval2; break;
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
549 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
550 }
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
551 return make_float (dval1);
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1983
diff changeset
552 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
553 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
554 #else /* !WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 EMACS_INT ival1, ival2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 int float_p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 float_p = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 if (INTP (obj1)) ival1 = XINT (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 else if (FLOATP (obj1)) ival1 = 0, float_p = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
567 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
571
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572 if (INTP (obj2)) ival2 = XINT (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
573 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
575 else if (FLOATP (obj2)) ival2 = 0, float_p = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
576 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582 if (!float_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 switch (opcode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586 case Bplus: ival1 += ival2; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 case Bdiff: ival1 -= ival2; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 case Bmult: ival1 *= ival2; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 case Bquo:
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
590 if (ival2 == 0)
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
591 signal_error_2 (Qarith_error, "division by zero", obj1, obj2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592 ival1 /= ival2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597 return make_int (ival1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
600 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601 double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
602 double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603 switch (opcode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605 case Bplus: dval1 += dval2; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606 case Bdiff: dval1 -= dval2; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607 case Bmult: dval1 *= dval2; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608 case Bquo:
4717
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
609 if (dval2 == 0)
fcc7e89d5e68 Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents: 4678
diff changeset
610 signal_error_2 (Qarith_error, "division by zero", obj1, obj2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 dval1 /= dval2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613 case Bmax: if (dval1 < dval2) dval1 = dval2; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
616 return make_float (dval1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
618 #endif /* WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
619 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 /* Read next uint8 from the instruction stream. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 /* Read next uint16 from the instruction stream. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626 #define READ_UINT_2 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
627 (program_ptr += 2, \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 ((unsigned int) (unsigned char) program_ptr[-2])))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631 /* Read next int8 from the instruction stream. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
632 #define READ_INT_1 ((int) (signed char) *program_ptr++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634 /* Read next int16 from the instruction stream. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635 #define READ_INT_2 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 (program_ptr += 2, \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637 (((int) ( signed char) program_ptr[-1]) * 256 + \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 ((int) (unsigned char) program_ptr[-2])))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 /* Read next int8 from instruction stream; don't advance program_pointer */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
643 /* Read next int16 from instruction stream; don't advance program_pointer */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644 #define PEEK_INT_2 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 ((((int) ( signed char) program_ptr[1]) * 256) | \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 ((int) (unsigned char) program_ptr[0]))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 /* Do relative jumps from the current location.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649 We only do a QUIT if we jump backwards, for efficiency.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 No infloops without backward jumps! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 #define JUMP_RELATIVE(jump) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 int JR_jump = (jump); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 if (JR_jump < 0) QUIT; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654 program_ptr += JR_jump; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
656
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657 #define JUMP JUMP_RELATIVE (PEEK_INT_2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660 #define JUMP_NEXT ((void) (program_ptr += 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661 #define JUMPR_NEXT ((void) (program_ptr += 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 /* Push x onto the execution stack. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 #define PUSH(x) (*++stack_ptr = (x))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
666 /* Pop a value, which may be multiple, off the execution stack. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
667 #define POP_WITH_MULTIPLE_VALUES (*stack_ptr--)
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
668
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
669 /* Pop a value off the execution stack, treating multiple values as single. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
670 #define POP (IGNORE_MULTIPLE_VALUES (POP_WITH_MULTIPLE_VALUES))
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
671
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
672 #define DISCARD_PRESERVING_MULTIPLE_VALUES(n) (stack_ptr -= (n))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 /* Discard n values from the execution stack. */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
675 #define DISCARD(n) do { \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
676 if (1 != multiple_value_current_limit) \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
677 { \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
678 int i, en = n; \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
679 for (i = 0; i < en; i++) \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
680 { \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
681 *stack_ptr = ignore_multiple_values (*stack_ptr); \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
682 stack_ptr--; \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
683 } \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
684 } \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
685 else \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
686 { \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
687 stack_ptr -= (n); \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
688 } \
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
689 } while (0)
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
690
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
691 /* Get the value, which may be multiple, at the top of the execution stack;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
692 and leave it there. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
693 #define TOP_WITH_MULTIPLE_VALUES (*stack_ptr)
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
694
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
695 #define TOP_ADDRESS (stack_ptr)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 /* Get the value which is at the top of the execution stack,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698 but don't pop it. */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
699 #define TOP (IGNORE_MULTIPLE_VALUES (TOP_WITH_MULTIPLE_VALUES))
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
700
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
701 #define TOP_LVALUE (*stack_ptr)
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
702
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
703
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
705 /* See comment before the big switch in execute_optimized_program(). */
1884
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
706 #define GCPRO_STACK (gcpro1.nvars = stack_ptr - stack_beg)
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
707
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 /* The actual interpreter for byte code.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 This function has been seriously optimized for performance.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 Don't change the constructs unless you are willing to do
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 real benchmarking and profiling work -- martin */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
714 Lisp_Object
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
715 execute_optimized_program (const Opbyte *program,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 int stack_depth,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717 Lisp_Object *constants_data)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719 /* This function can GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
720 REGISTER const Opbyte *program_ptr = (Opbyte *) program;
1884
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
721 Lisp_Object *stack_beg = alloca_array (Lisp_Object, stack_depth + 1);
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
722 REGISTER Lisp_Object *stack_ptr = stack_beg;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 int speccount = specpdl_depth ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 #ifdef BYTE_CODE_METER
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
727 Opcode this_opcode = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
728 Opcode prev_opcode;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
730
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 #ifdef ERROR_CHECK_BYTE_CODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 Lisp_Object *stack_end = stack_beg + stack_depth;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
735 /* We used to GCPRO the whole interpreter stack before entering this while
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
736 loop (21.5.14 and before), but that interferes with collection of weakly
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
737 referenced objects. Although strictly speaking there's no promise that
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
738 weak references will disappear by any given point in time, they should
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
739 be collected at the first opportunity. Waiting until exit from the
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
740 function caused test failures because "stale" objects "above" the top of
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
741 the stack were still GCPROed, and they were not getting collected until
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
742 after exit from the (byte-compiled) test!
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
743
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
744 Now the idea is to dynamically adjust the array of GCPROed objects to
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
745 include only the "active" region of the stack.
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
746
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
747 We use the "GCPRO1 the array base and set the nvars member" method. It
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
748 would be slightly inefficient but correct to use GCPRO1_ARRAY here. It
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
749 would just redundantly set nvars.
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
750 #### Maybe it would be clearer to use GCPRO1_ARRAY and do GCPRO_STACK
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
751 after the switch?
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
752
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
753 GCPRO_STACK is something of a misnomer, because it suggests that a
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
754 struct gcpro is initialized each time. This is false; only the nvars
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
755 member of a single struct gcpro is being adjusted. This works because
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
756 each time a new object is assigned to a stack location, the old object
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
757 loses its reference and is effectively UNGCPROed, and the new object is
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
758 automatically GCPROed as long as nvars is correct. Only when we
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
759 return from the interpreter do we need to finalize the struct gcpro
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
760 itself, and that's done at case Breturn.
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
761 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 GCPRO1 (stack_ptr[1]);
1758
90502933fb98 [xemacs-hg @ 2003-10-21 08:21:00 by stephent]
stephent
parents: 1737
diff changeset
763
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
765 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
766 REGISTER Opcode opcode = (Opcode) READ_UINT_1;
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
767
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
768 GCPRO_STACK; /* Get nvars right before maybe signaling. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769 #ifdef ERROR_CHECK_BYTE_CODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 if (stack_ptr > stack_end)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
771 stack_overflow ("byte code stack overflow", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772 if (stack_ptr < stack_beg)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
773 stack_overflow ("byte code stack underflow", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
774 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
775
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
776 #ifdef BYTE_CODE_METER
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
777 prev_opcode = this_opcode;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
778 this_opcode = opcode;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779 meter_code (prev_opcode, this_opcode);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
780 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
781
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
782 switch (opcode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
784 REGISTER int n;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
786 default:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
787 if (opcode >= Bconstant)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
788 PUSH (constants_data[opcode - Bconstant]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 else
1884
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
790 {
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
791 /* We're not sure what these do, so better safe than sorry. */
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
792 /* GCPRO_STACK; */
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
793 stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode);
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
794 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
795 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
796
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797 case Bvarref:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
798 case Bvarref+1:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799 case Bvarref+2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800 case Bvarref+3:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
801 case Bvarref+4:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
802 case Bvarref+5: n = opcode - Bvarref; goto do_varref;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
803 case Bvarref+7: n = READ_UINT_2; goto do_varref;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
804 case Bvarref+6: n = READ_UINT_1; /* most common */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 do_varref:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 Lisp_Object symbol = constants_data[n];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 Lisp_Object value = XSYMBOL (symbol)->value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 if (SYMBOL_VALUE_MAGIC_P (value))
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
810 /* I GCPRO_STACKed Fsymbol_value elsewhere, but I dunno why. */
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
811 /* GCPRO_STACK; */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 value = Fsymbol_value (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 PUSH (value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 case Bvarset:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818 case Bvarset+1:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819 case Bvarset+2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820 case Bvarset+3:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821 case Bvarset+4:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
822 case Bvarset+5: n = opcode - Bvarset; goto do_varset;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 case Bvarset+7: n = READ_UINT_2; goto do_varset;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 case Bvarset+6: n = READ_UINT_1; /* most common */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 do_varset:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 Lisp_Object symbol = constants_data[n];
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
828 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829 Lisp_Object old_value = symbol_ptr->value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
830 Lisp_Object new_value = POP;
1661
2264738f7ae4 [xemacs-hg @ 2003-09-02 13:18:14 by michaels]
michaels
parents: 1630
diff changeset
831 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832 symbol_ptr->value = new_value;
1884
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
833 else {
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
834 /* Fset may call magic handlers */
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
835 /* GCPRO_STACK; */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 Fset (symbol, new_value);
1884
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
837 }
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
838
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
839 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842 case Bvarbind:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843 case Bvarbind+1:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 case Bvarbind+2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 case Bvarbind+3:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 case Bvarbind+4:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847 case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
848 case Bvarbind+7: n = READ_UINT_2; goto do_varbind;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849 case Bvarbind+6: n = READ_UINT_1; /* most common */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
850 do_varbind:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
851 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852 Lisp_Object symbol = constants_data[n];
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
853 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 Lisp_Object old_value = symbol_ptr->value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 Lisp_Object new_value = POP;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
857 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
858 specpdl_ptr->symbol = symbol;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859 specpdl_ptr->old_value = old_value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 specpdl_ptr->func = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 specpdl_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 specpdl_depth_counter++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 symbol_ptr->value = new_value;
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 844
diff changeset
865
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 844
diff changeset
866 #ifdef ERROR_CHECK_CATCH
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 844
diff changeset
867 check_specbind_stack_sanity ();
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 844
diff changeset
868 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 else
1884
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
871 {
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
872 /* does an Fset, may call magic handlers */
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
873 /* GCPRO_STACK; */
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
874 specbind_magic (symbol, new_value);
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
875 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 case Bcall:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 case Bcall+1:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 case Bcall+2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 case Bcall+3:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 case Bcall+4:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 case Bcall+5:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 case Bcall+6:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 case Bcall+7:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 n = (opcode < Bcall+6 ? opcode - Bcall :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888 opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2);
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
889 /* #### Shouldn't this be just before the Ffuncall?
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
890 Neither Fget nor Fput can GC. */
1884
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
891 /* GCPRO_STACK; */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 DISCARD (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893 #ifdef BYTE_CODE_METER
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
894 if (byte_metering_on && SYMBOLP (TOP))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 if (INTP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
898 Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
899 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900 #endif
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
901 TOP_LVALUE = TOP; /* Ignore multiple values. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
902 TOP_LVALUE = Ffuncall (n + 1, TOP_ADDRESS);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
904
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905 case Bunbind:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
906 case Bunbind+1:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
907 case Bunbind+2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
908 case Bunbind+3:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
909 case Bunbind+4:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
910 case Bunbind+5:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
911 case Bunbind+6:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
912 case Bunbind+7:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
913 UNBIND_TO (specpdl_depth() -
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
914 (opcode < Bunbind+6 ? opcode-Bunbind :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
915 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
916 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
917
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
918
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
919 case Bgoto:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920 JUMP;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
922
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
923 case Bgotoifnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924 if (NILP (POP))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
925 JUMP;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
926 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
927 JUMP_NEXT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
928 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
929
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
930 case Bgotoifnonnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931 if (!NILP (POP))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
932 JUMP;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
933 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
934 JUMP_NEXT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
935 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937 case Bgotoifnilelsepop:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
938 /* Discard any multiple value: */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
939 if (NILP (TOP_LVALUE = TOP))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940 JUMP;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
943 DISCARD (1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
944 JUMP_NEXT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
945 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 case Bgotoifnonnilelsepop:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
949 /* Discard any multiple value: */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
950 if (!NILP (TOP_LVALUE = TOP))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
951 JUMP;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
952 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
953 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954 DISCARD (1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 JUMP_NEXT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
958
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
959
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
960 case BRgoto:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
961 JUMPR;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
962 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964 case BRgotoifnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
965 if (NILP (POP))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
966 JUMPR;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
967 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
968 JUMPR_NEXT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
969 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
970
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971 case BRgotoifnonnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972 if (!NILP (POP))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
973 JUMPR;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
974 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 JUMPR_NEXT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
976 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
977
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
978 case BRgotoifnilelsepop:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
979 if (NILP (TOP_LVALUE = TOP))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 JUMPR;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983 DISCARD (1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
984 JUMPR_NEXT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988 case BRgotoifnonnilelsepop:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
989 if (!NILP (TOP_LVALUE = TOP))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990 JUMPR;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
993 DISCARD (1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
994 JUMPR_NEXT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
998 case Breturn:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
999 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 #ifdef ERROR_CHECK_BYTE_CODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001 /* Binds and unbinds are supposed to be compiled balanced. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1002 if (specpdl_depth() != speccount)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1003 invalid_byte_code ("unbalanced specbinding stack", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004 #endif
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1005 return TOP_WITH_MULTIPLE_VALUES;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1006
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1007 case Bdiscard:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1008 DISCARD (1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1009 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1011 case Bdup:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1012 {
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1013 Lisp_Object arg = TOP_WITH_MULTIPLE_VALUES;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1014 PUSH (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1015 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1016 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1017
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1018 case Bconstant2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1019 PUSH (constants_data[READ_UINT_2]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1020 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1021
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1022 case Bcar:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1023 {
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1024 /* Fcar can GC via wrong_type_argument. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1025 /* GCPRO_STACK; */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1026 Lisp_Object arg = TOP;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1027 TOP_LVALUE = CONSP (arg) ? XCAR (arg) : Fcar (arg);
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1028 break;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1029 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1030
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031 case Bcdr:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1032 {
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1033 /* Fcdr can GC via wrong_type_argument. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1034 /* GCPRO_STACK; */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1035 Lisp_Object arg = TOP;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1036 TOP_LVALUE = CONSP (arg) ? XCDR (arg) : Fcdr (arg);
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1037 break;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1038 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1039
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1040 case Bunbind_all:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1041 /* To unbind back to the beginning of this frame. Not used yet,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1042 but will be needed for tail-recursion elimination. */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 665
diff changeset
1043 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1044 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1045
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1046 case Bnth:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1047 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1048 Lisp_Object arg = POP;
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1049 /* Fcar and Fnthcdr can GC via wrong_type_argument. */
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1050 /* GCPRO_STACK; */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1051 TOP_LVALUE = Fcar (Fnthcdr (TOP, arg));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1052 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1053 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1054
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1055 case Bsymbolp:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1056 TOP_LVALUE = SYMBOLP (TOP) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1057 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1058
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1059 case Bconsp:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1060 TOP_LVALUE = CONSP (TOP) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1061 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1062
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1063 case Bstringp:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1064 TOP_LVALUE = STRINGP (TOP) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1065 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1066
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1067 case Blistp:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1068 TOP_LVALUE = LISTP (TOP) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1069 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1070
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1071 case Bnumberp:
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1072 #ifdef WITH_NUMBER_TYPES
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1073 TOP_LVALUE = NUMBERP (TOP) ? Qt : Qnil;
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1074 #else
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1075 TOP_LVALUE = INT_OR_FLOATP (TOP) ? Qt : Qnil;
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1076 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1077 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1078
4885
6772ce4d982b Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents: 4775
diff changeset
1079 case Bfixnump:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1080 TOP_LVALUE = INTP (TOP) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1081 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1082
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1083 case Beq:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1084 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1085 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1086 TOP_LVALUE = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1087 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1088 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1089
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1090 case Bnot:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1091 TOP_LVALUE = NILP (TOP) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1092 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1093
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1094 case Bcons:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1095 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1096 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1097 TOP_LVALUE = Fcons (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1098 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1099 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1100
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1101 case Blist1:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1102 TOP_LVALUE = Fcons (TOP, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1103 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1104
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1105
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1106 case BlistN:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1107 n = READ_UINT_1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1108 goto do_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1109
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1110 case Blist2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1111 case Blist3:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1112 case Blist4:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1113 /* common case */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1114 n = opcode - (Blist1 - 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1115 do_list:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1116 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1117 Lisp_Object list = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1118 list_loop:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1119 list = Fcons (TOP, list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1120 if (--n)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1121 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1122 DISCARD (1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1123 goto list_loop;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1124 }
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1125 TOP_LVALUE = list;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1126 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1127 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1128
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1129
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1130 case Bconcat2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1131 case Bconcat3:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1132 case Bconcat4:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1133 n = opcode - (Bconcat2 - 2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1134 goto do_concat;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1135
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1136 case BconcatN:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1137 /* common case */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1138 n = READ_UINT_1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1139 do_concat:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1140 DISCARD (n - 1);
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1141 /* Apparently `concat' can GC; Fconcat GCPROs its arguments. */
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1142 /* GCPRO_STACK; */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1143 TOP_LVALUE = TOP; /* Ignore multiple values. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1144 TOP_LVALUE = Fconcat (n, TOP_ADDRESS);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1145 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1146
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1147
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1148 case Blength:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1149 TOP_LVALUE = Flength (TOP);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1150 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1151
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1152 case Baset:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1153 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1154 Lisp_Object arg2 = POP;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1155 Lisp_Object arg1 = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1156 TOP_LVALUE = Faset (TOP, arg1, arg2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1157 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1159
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1160 case Bsymbol_value:
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1161 /* Why does this need GCPRO_STACK? If not, remove others, too. */
1884
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
1162 /* GCPRO_STACK; */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1163 TOP_LVALUE = Fsymbol_value (TOP);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1164 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1165
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1166 case Bsymbol_function:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1167 TOP_LVALUE = Fsymbol_function (TOP);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1168 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1169
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1170 case Bget:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1171 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1172 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1173 TOP_LVALUE = Fget (TOP, arg, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1174 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1175 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1176
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1177 case Bsub1:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1178 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1179 #ifdef HAVE_BIGNUM
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1180 TOP_LVALUE = Fsub1 (TOP);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1181 #else
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1182 Lisp_Object arg = TOP;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1183 TOP_LVALUE = INTP (arg) ? INT_MINUS1 (arg) : Fsub1 (arg);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1184 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1185 break;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1186 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1187 case Badd1:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1188 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1189 #ifdef HAVE_BIGNUM
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1190 TOP_LVALUE = Fadd1 (TOP);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1191 #else
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1192 Lisp_Object arg = TOP;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1193 TOP_LVALUE = INTP (arg) ? INT_PLUS1 (arg) : Fadd1 (arg);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1194 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1195 break;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1196 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1197
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1198 case Beqlsign:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1199 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1200 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1201 TOP_LVALUE = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1202 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1203 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1204
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1205 case Bgtr:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1206 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1207 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1208 TOP_LVALUE = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1209 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1210 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1211
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1212 case Blss:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1213 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1214 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1215 TOP_LVALUE = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1218
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1219 case Bleq:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1220 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1221 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1222 TOP_LVALUE = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1226 case Bgeq:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1227 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1228 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1229 TOP_LVALUE = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1230 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1231 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1232
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1233
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 case Bnegate:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1235 TOP_LVALUE = bytecode_negate (TOP);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1236 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1237
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1238 case Bnconc:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1239 DISCARD (1);
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1240 /* nconc2 GCPROs before calling this. */
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1241 /* GCPRO_STACK; */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1242 TOP_LVALUE = TOP; /* Ignore multiple values. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1243 TOP_LVALUE = bytecode_nconc2 (TOP_ADDRESS);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1244 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1245
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1246 case Bplus:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1247 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1248 Lisp_Object arg2 = POP;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1249 Lisp_Object arg1 = TOP;
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1250 #ifdef HAVE_BIGNUM
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1251 TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1252 #else
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1253 TOP_LVALUE = INTP (arg1) && INTP (arg2) ?
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1254 INT_PLUS (arg1, arg2) :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1255 bytecode_arithop (arg1, arg2, opcode);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1256 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1257 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1258 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1260 case Bdiff:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262 Lisp_Object arg2 = POP;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1263 Lisp_Object arg1 = TOP;
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1264 #ifdef HAVE_BIGNUM
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1265 TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1266 #else
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1267 TOP_LVALUE = INTP (arg1) && INTP (arg2) ?
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1268 INT_MINUS (arg1, arg2) :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1269 bytecode_arithop (arg1, arg2, opcode);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
1270 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1271 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1272 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1273
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1274 case Bmult:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1275 case Bquo:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1276 case Bmax:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1277 case Bmin:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1278 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1279 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1280 TOP_LVALUE = bytecode_arithop (TOP, arg, opcode);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1281 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1282 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1283
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1284 case Bpoint:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1285 PUSH (make_int (BUF_PT (current_buffer)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1286 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1287
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1288 case Binsert:
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1289 /* Says it can GC. */
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1290 /* GCPRO_STACK; */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1291 TOP_LVALUE = TOP; /* Ignore multiple values. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1292 TOP_LVALUE = Finsert (1, TOP_ADDRESS);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1293 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1294
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1295 case BinsertN:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1296 n = READ_UINT_1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1297 DISCARD (n - 1);
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1298 /* See Binsert. */
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1299 /* GCPRO_STACK; */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1300 TOP_LVALUE = TOP; /* Ignore multiple values. */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1301 TOP_LVALUE = Finsert (n, TOP_ADDRESS);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1302 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1303
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1304 case Baref:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1305 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1307 TOP_LVALUE = Faref (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1308 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1309 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1311 case Bmemq:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1312 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1313 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1314 TOP_LVALUE = Fmemq (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1315 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1316 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1317
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1318 case Bset:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1319 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1320 Lisp_Object arg = POP;
1884
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
1321 /* Fset may call magic handlers */
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
1322 /* GCPRO_STACK; */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1323 TOP_LVALUE = Fset (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1324 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1325 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1326
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1327 case Bequal:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1328 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1329 Lisp_Object arg = POP;
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1330 /* Can QUIT, so can GC, right? */
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1331 /* GCPRO_STACK; */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1332 TOP_LVALUE = Fequal (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1333 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1334 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1335
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1336 case Bnthcdr:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1337 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1338 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1339 TOP_LVALUE = Fnthcdr (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1340 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1341 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343 case Belt:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1344 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1345 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1346 TOP_LVALUE = Felt (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1348 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1349
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1350 case Bmember:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1351 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1352 Lisp_Object arg = POP;
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1353 /* Can QUIT, so can GC, right? */
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1354 /* GCPRO_STACK; */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1355 TOP_LVALUE = Fmember (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1356 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1357 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1358
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1359 case Bgoto_char:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1360 TOP_LVALUE = Fgoto_char (TOP, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1361 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1362
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1363 case Bcurrent_buffer:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1364 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
1365 Lisp_Object buffer = wrap_buffer (current_buffer);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
1366
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1367 PUSH (buffer);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1368 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1369 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1370
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1371 case Bset_buffer:
1884
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
1372 /* #### WAG: set-buffer may cause Fset's of buffer locals
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
1373 Didn't prevent crash. :-( */
3d25fd3d9ac4 [xemacs-hg @ 2004-01-27 13:23:50 by stephent]
stephent
parents: 1758
diff changeset
1374 /* GCPRO_STACK; */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1375 TOP_LVALUE = Fset_buffer (TOP);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1376 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1377
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1378 case Bpoint_max:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1379 PUSH (make_int (BUF_ZV (current_buffer)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1380 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1381
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1382 case Bpoint_min:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1383 PUSH (make_int (BUF_BEGV (current_buffer)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1384 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1385
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1386 case Bskip_chars_forward:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1387 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1388 Lisp_Object arg = POP;
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1389 /* Can QUIT, so can GC, right? */
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1884
diff changeset
1390 /* GCPRO_STACK; */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1391 TOP_LVALUE = Fskip_chars_forward (TOP, arg, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1392 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1393 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1394
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1395 case Bassq:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1396 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1397 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1398 TOP_LVALUE = Fassq (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1399 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1400 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1401
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1402 case Bsetcar:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1403 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1404 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1405 TOP_LVALUE = Fsetcar (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1406 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1407 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1408
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1409 case Bsetcdr:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1410 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1411 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1412 TOP_LVALUE = Fsetcdr (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1413 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1414 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1415
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1416 case Bnreverse:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1417 TOP_LVALUE = bytecode_nreverse (TOP);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1418 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1419
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1420 case Bcar_safe:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1421 TOP_LVALUE = CONSP (TOP) ? XCAR (TOP) : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1422 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1423
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1424 case Bcdr_safe:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1425 TOP_LVALUE = CONSP (TOP) ? XCDR (TOP) : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1426 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1427
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1428 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1429 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1430 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1431
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1432 /* It makes a worthwhile performance difference (5%) to shunt
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1433 lesser-used opcodes off to a subroutine, to keep the switch in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1434 execute_optimized_program small. If you REALLY care about
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1435 performance, you want to keep your heavily executed code away from
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1436 rarely executed code, to minimize cache misses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1437
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1438 Don't make this function static, since then the compiler might inline it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1439 Lisp_Object *
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1440 execute_rare_opcode (Lisp_Object *stack_ptr,
2286
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 1995
diff changeset
1441 const Opbyte *UNUSED (program_ptr),
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1442 Opcode opcode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1443 {
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1444 REGISTER int n;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1445
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1446 switch (opcode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1447 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1448
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1449 case Bsave_excursion:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1450 record_unwind_protect (save_excursion_restore,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1451 save_excursion_save ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1452 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1453
4775
1d61580e0cf7 Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4717
diff changeset
1454 /* This bytecode will eventually go away, once we no longer encounter
1d61580e0cf7 Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4717
diff changeset
1455 byte code from 21.4. In 21.5.10 and newer, save-window-excursion is
1d61580e0cf7 Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4717
diff changeset
1456 a macro. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1457 case Bsave_window_excursion:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1458 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1459 int count = specpdl_depth ();
4775
1d61580e0cf7 Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4717
diff changeset
1460 record_unwind_protect (Feval,
1d61580e0cf7 Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4717
diff changeset
1461 list2 (Qset_window_configuration,
1d61580e0cf7 Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4717
diff changeset
1462 call0 (Qcurrent_window_configuration)));
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1463 TOP_LVALUE = Fprogn (TOP);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 665
diff changeset
1464 unbind_to (count);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1465 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1466 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1467
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1468 case Bsave_restriction:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1469 record_unwind_protect (save_restriction_restore,
844
047d37eb70d7 [xemacs-hg @ 2002-05-16 13:30:23 by ben]
ben
parents: 826
diff changeset
1470 save_restriction_save (current_buffer));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1471 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1472
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1473 case Bcatch:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1474 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1475 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1476 TOP_LVALUE = internal_catch (TOP, Feval, arg, 0, 0, 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1477 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1478 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1479
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1480 case Bskip_chars_backward:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1481 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1482 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1483 TOP_LVALUE = Fskip_chars_backward (TOP, arg, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1484 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1485 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1486
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1487 case Bunwind_protect:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1488 record_unwind_protect (Fprogn, POP);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1489 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1490
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1491 case Bcondition_case:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1492 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1493 Lisp_Object arg2 = POP; /* handlers */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1494 Lisp_Object arg1 = POP; /* bodyform */
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1495 TOP_LVALUE = condition_case_3 (arg1, TOP, arg2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1496 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1497 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1498
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1499 case Bset_marker:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1500 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1501 Lisp_Object arg2 = POP;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1502 Lisp_Object arg1 = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1503 TOP_LVALUE = Fset_marker (TOP, arg1, arg2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1504 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1505 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1506
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1507 case Brem:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1508 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1509 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1510 TOP_LVALUE = Frem (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1511 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1512 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1513
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1514 case Bmatch_beginning:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1515 TOP_LVALUE = Fmatch_beginning (TOP);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1516 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1517
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1518 case Bmatch_end:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1519 TOP_LVALUE = Fmatch_end (TOP);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1520 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1521
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1522 case Bupcase:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1523 TOP_LVALUE = Fupcase (TOP, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1524 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1525
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1526 case Bdowncase:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1527 TOP_LVALUE = Fdowncase (TOP, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1528 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1529
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1530 case Bfset:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1531 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1532 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1533 TOP_LVALUE = Ffset (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1534 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1535 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1536
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1537 case Bstring_equal:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1538 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1539 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1540 TOP_LVALUE = Fstring_equal (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1541 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1542 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1543
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1544 case Bstring_lessp:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1545 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1546 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1547 TOP_LVALUE = Fstring_lessp (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1548 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1549 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1550
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1551 case Bsubstring:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1552 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1553 Lisp_Object arg2 = POP;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1554 Lisp_Object arg1 = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1555 TOP_LVALUE = Fsubstring (TOP, arg1, arg2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1556 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1557 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1558
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1559 case Bcurrent_column:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1560 PUSH (make_int (current_column (current_buffer)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1561 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1562
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1563 case Bchar_after:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1564 TOP_LVALUE = Fchar_after (TOP, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1565 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1566
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1567 case Bindent_to:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1568 TOP_LVALUE = Findent_to (TOP, Qnil, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1569 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1570
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1571 case Bwiden:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1572 PUSH (Fwiden (Qnil));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1573 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1574
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1575 case Bfollowing_char:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1576 PUSH (Ffollowing_char (Qnil));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1577 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1578
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1579 case Bpreceding_char:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1580 PUSH (Fpreceding_char (Qnil));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1581 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1582
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1583 case Beolp:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1584 PUSH (Feolp (Qnil));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1585 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1586
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1587 case Beobp:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1588 PUSH (Feobp (Qnil));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1589 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1590
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1591 case Bbolp:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1592 PUSH (Fbolp (Qnil));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1593 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1594
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1595 case Bbobp:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1596 PUSH (Fbobp (Qnil));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1597 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1598
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1599 case Bsave_current_buffer:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1600 record_unwind_protect (save_current_buffer_restore,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1601 Fcurrent_buffer ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1602 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1603
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1604 case Binteractive_p:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1605 PUSH (Finteractive_p ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1606 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1607
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1608 case Bforward_char:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1609 TOP_LVALUE = Fforward_char (TOP, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1610 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1611
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1612 case Bforward_word:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1613 TOP_LVALUE = Fforward_word (TOP, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1614 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1615
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1616 case Bforward_line:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1617 TOP_LVALUE = Fforward_line (TOP, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1618 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1619
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1620 case Bchar_syntax:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1621 TOP_LVALUE = Fchar_syntax (TOP, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1622 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1623
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1624 case Bbuffer_substring:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1625 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1626 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1627 TOP_LVALUE = Fbuffer_substring (TOP, arg, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1628 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1629 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1630
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1631 case Bdelete_region:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1632 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1633 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1634 TOP_LVALUE = Fdelete_region (TOP, arg, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1635 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1636 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1637
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1638 case Bnarrow_to_region:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1639 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1640 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1641 TOP_LVALUE = Fnarrow_to_region (TOP, arg, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1642 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1643 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1644
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1645 case Bend_of_line:
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1646 TOP_LVALUE = Fend_of_line (TOP, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1647 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1648
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1649 case Btemp_output_buffer_setup:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1650 temp_output_buffer_setup (TOP);
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1651 TOP_LVALUE = Vstandard_output;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1652 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1653
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1654 case Btemp_output_buffer_show:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1655 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1656 Lisp_Object arg = POP;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1657 temp_output_buffer_show (TOP, Qnil);
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1658 TOP_LVALUE = arg;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1659 /* GAG ME!! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1660 /* pop binding of standard-output */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 665
diff changeset
1661 unbind_to (specpdl_depth() - 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1662 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1663 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1664
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1665 case Bold_eq:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1666 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1667 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1668 TOP_LVALUE = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1669 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1670 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1671
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1672 case Bold_memq:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1673 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1674 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1675 TOP_LVALUE = Fold_memq (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1676 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1677 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1678
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1679 case Bold_equal:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1680 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1681 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1682 TOP_LVALUE = Fold_equal (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1683 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1684 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1685
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1686 case Bold_member:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1687 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1688 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1689 TOP_LVALUE = Fold_member (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1690 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1691 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1692
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1693 case Bold_assq:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1694 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1695 Lisp_Object arg = POP;
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1696 TOP_LVALUE = Fold_assq (TOP, arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1697 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1698 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1699
4677
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1700 case Bbind_multiple_value_limits:
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1701 {
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1702 Lisp_Object upper = POP, first = TOP, speccount;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1703
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1704 CHECK_NATNUM (upper);
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1705 CHECK_NATNUM (first);
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1706
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1707 speccount = make_int (bind_multiple_value_limits (XINT (first),
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1708 XINT (upper)));
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1709 PUSH (upper);
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1710 PUSH (speccount);
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1711 break;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1712 }
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1713
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1714 case Bmultiple_value_call:
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1715 {
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1716 n = XINT (POP);
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1717 DISCARD_PRESERVING_MULTIPLE_VALUES (n - 1);
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1718 /* Discard multiple values for the first (function) argument: */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1719 TOP_LVALUE = TOP;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1720 TOP_LVALUE = multiple_value_call (n, TOP_ADDRESS);
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1721 break;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1722 }
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1723
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1724 case Bmultiple_value_list_internal:
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1725 {
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1726 DISCARD_PRESERVING_MULTIPLE_VALUES (3);
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1727 TOP_LVALUE = multiple_value_list_internal (4, TOP_ADDRESS);
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1728 break;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1729 }
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1730
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1731 case Bthrow:
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1732 {
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1733 Lisp_Object arg = POP_WITH_MULTIPLE_VALUES;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1734
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1735 /* We never throw to a catch tag that is a multiple value: */
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1736 throw_or_bomb_out (TOP, arg, 0, Qnil, Qnil);
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1737 break;
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1738 }
8f1ee2d15784 Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3263
diff changeset
1739
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1740 default:
2500
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
1741 ABORT();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1742 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1743 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1744 return stack_ptr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1745 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1746
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1747
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1748 DOESNT_RETURN
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1749 invalid_byte_code (const CIbyte *reason, Lisp_Object frob)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1750 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1751 signal_error (Qinvalid_byte_code, reason, frob);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1752 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1753
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1754 /* Check for valid opcodes. Change this when adding new opcodes. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1755 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1756 check_opcode (Opcode opcode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1757 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1758 if ((opcode < Bvarref) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1759 (opcode == 0251) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1760 (opcode > Bassq && opcode < Bconstant))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1761 invalid_byte_code ("invalid opcode in instruction stream",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1762 make_int (opcode));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1763 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1764
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1765 /* Check that IDX is a valid offset into the `constants' vector */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1766 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1767 check_constants_index (int idx, Lisp_Object constants)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1768 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1769 if (idx < 0 || idx >= XVECTOR_LENGTH (constants))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1770 signal_ferror
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1771 (Qinvalid_byte_code,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1772 "reference %d to constants array out of range 0, %ld",
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1773 idx, XVECTOR_LENGTH (constants) - 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1774 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1775
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1776 /* Get next character from Lisp instructions string. */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1777 #define READ_INSTRUCTION_CHAR(lvalue) do { \
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1778 (lvalue) = itext_ichar (ptr); \
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1779 INC_IBYTEPTR (ptr); \
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1780 *icounts_ptr++ = program_ptr - program; \
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1781 if (lvalue > UCHAR_MAX) \
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1782 invalid_byte_code \
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1783 ("Invalid character in byte code string", make_char (lvalue)); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1784 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1785
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1786 /* Get opcode from Lisp instructions string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1787 #define READ_OPCODE do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1788 unsigned int c; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1789 READ_INSTRUCTION_CHAR (c); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1790 opcode = (Opcode) c; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1791 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1792
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1793 /* Get next operand, a uint8, from Lisp instructions string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1794 #define READ_OPERAND_1 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1795 READ_INSTRUCTION_CHAR (arg); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1796 argsize = 1; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1797 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1798
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1799 /* Get next operand, a uint16, from Lisp instructions string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1800 #define READ_OPERAND_2 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1801 unsigned int arg1, arg2; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1802 READ_INSTRUCTION_CHAR (arg1); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1803 READ_INSTRUCTION_CHAR (arg2); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1804 arg = arg1 + (arg2 << 8); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1805 argsize = 2; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1806 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1807
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1808 /* Write 1 byte to PTR, incrementing PTR */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1809 #define WRITE_INT8(value, ptr) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1810 *((ptr)++) = (value); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1811 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1812
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1813 /* Write 2 bytes to PTR, incrementing PTR */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1814 #define WRITE_INT16(value, ptr) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1815 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1816 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1817 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1818
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1819 /* We've changed our minds about the opcode we've already written. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1820 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1821
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1822 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1823 #define WRITE_NARGS(base_opcode) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1824 if (arg <= 5) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1825 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1826 REWRITE_OPCODE (base_opcode + arg); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1827 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1828 else if (arg <= UCHAR_MAX) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1829 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1830 REWRITE_OPCODE (base_opcode + 6); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1831 WRITE_INT8 (arg, program_ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1832 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1833 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1834 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1835 REWRITE_OPCODE (base_opcode + 7); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1836 WRITE_INT16 (arg, program_ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1837 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1838 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1839
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1840 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1841 #define WRITE_CONSTANT do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1842 check_constants_index(arg, constants); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1843 if (arg <= UCHAR_MAX - Bconstant) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1844 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1845 REWRITE_OPCODE (Bconstant + arg); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1846 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1847 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1848 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1849 REWRITE_OPCODE (Bconstant2); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1850 WRITE_INT16 (arg, program_ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1851 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1852 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1853
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1854 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1855
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1856 /* Compile byte code instructions into free space provided by caller, with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1857 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1858 Returns length of compiled code. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1859 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1860 optimize_byte_code (/* in */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1861 Lisp_Object instructions,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1862 Lisp_Object constants,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1863 /* out */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1864 Opbyte * const program,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1865 int * const program_length,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1866 int * const varbind_count)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1867 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 609
diff changeset
1868 Bytecount instructions_length = XSTRING_LENGTH (instructions);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1869 Elemcount comfy_size = (Elemcount) (2 * instructions_length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1870
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1871 int * const icounts = alloca_array (int, comfy_size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1872 int * icounts_ptr = icounts;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1873
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1874 /* We maintain a table of jumps in the source code. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1875 struct jump
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1876 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1877 int from;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1878 int to;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1879 };
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1880 struct jump * const jumps = alloca_array (struct jump, comfy_size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1881 struct jump *jumps_ptr = jumps;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1882
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1883 Opbyte *program_ptr = program;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1884
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1885 const Ibyte *ptr = XSTRING_DATA (instructions);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1886 const Ibyte * const end = ptr + instructions_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1887
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1888 *varbind_count = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1889
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1890 while (ptr < end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1891 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1892 Opcode opcode;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1893 int arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1894 int argsize = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1895 READ_OPCODE;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1896 WRITE_OPCODE;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1897
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1898 switch (opcode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1899 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1900 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1901
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1902 case Bvarref+7: READ_OPERAND_2; goto do_varref;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1903 case Bvarref+6: READ_OPERAND_1; goto do_varref;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1904 case Bvarref: case Bvarref+1: case Bvarref+2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1905 case Bvarref+3: case Bvarref+4: case Bvarref+5:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1906 arg = opcode - Bvarref;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1907 do_varref:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1908 check_constants_index (arg, constants);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1909 val = XVECTOR_DATA (constants) [arg];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1910 if (!SYMBOLP (val))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1911 invalid_byte_code ("variable reference to non-symbol", val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1912 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1913 invalid_byte_code ("variable reference to constant symbol", val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1914 WRITE_NARGS (Bvarref);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1915 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1916
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1917 case Bvarset+7: READ_OPERAND_2; goto do_varset;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1918 case Bvarset+6: READ_OPERAND_1; goto do_varset;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1919 case Bvarset: case Bvarset+1: case Bvarset+2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1920 case Bvarset+3: case Bvarset+4: case Bvarset+5:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1921 arg = opcode - Bvarset;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1922 do_varset:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1923 check_constants_index (arg, constants);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1924 val = XVECTOR_DATA (constants) [arg];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1925 if (!SYMBOLP (val))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1926 wtaerror ("attempt to set non-symbol", val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1927 if (EQ (val, Qnil) || EQ (val, Qt))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1928 signal_error (Qsetting_constant, 0, val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1929 /* Ignore assignments to keywords by converting to Bdiscard.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1930 For backward compatibility only - we'd like to make this an error. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1931 if (SYMBOL_IS_KEYWORD (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1932 REWRITE_OPCODE (Bdiscard);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1933 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1934 WRITE_NARGS (Bvarset);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1935 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1936
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1937 case Bvarbind+7: READ_OPERAND_2; goto do_varbind;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1938 case Bvarbind+6: READ_OPERAND_1; goto do_varbind;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1939 case Bvarbind: case Bvarbind+1: case Bvarbind+2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1940 case Bvarbind+3: case Bvarbind+4: case Bvarbind+5:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1941 arg = opcode - Bvarbind;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1942 do_varbind:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1943 (*varbind_count)++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1944 check_constants_index (arg, constants);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1945 val = XVECTOR_DATA (constants) [arg];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1946 if (!SYMBOLP (val))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1947 wtaerror ("attempt to let-bind non-symbol", val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1948 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1949 signal_error (Qsetting_constant,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1950 "attempt to let-bind constant symbol", val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1951 WRITE_NARGS (Bvarbind);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1952 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1953
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1954 case Bcall+7: READ_OPERAND_2; goto do_call;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1955 case Bcall+6: READ_OPERAND_1; goto do_call;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1956 case Bcall: case Bcall+1: case Bcall+2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1957 case Bcall+3: case Bcall+4: case Bcall+5:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1958 arg = opcode - Bcall;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1959 do_call:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1960 WRITE_NARGS (Bcall);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1961 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1962
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1963 case Bunbind+7: READ_OPERAND_2; goto do_unbind;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1964 case Bunbind+6: READ_OPERAND_1; goto do_unbind;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1965 case Bunbind: case Bunbind+1: case Bunbind+2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1966 case Bunbind+3: case Bunbind+4: case Bunbind+5:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1967 arg = opcode - Bunbind;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1968 do_unbind:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1969 WRITE_NARGS (Bunbind);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1970 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1971
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1972 case Bgoto:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1973 case Bgotoifnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1974 case Bgotoifnonnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1975 case Bgotoifnilelsepop:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1976 case Bgotoifnonnilelsepop:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1977 READ_OPERAND_2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1978 /* Make program_ptr-relative */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1979 arg += icounts - (icounts_ptr - argsize);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1980 goto do_jump;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1981
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1982 case BRgoto:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1983 case BRgotoifnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1984 case BRgotoifnonnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1985 case BRgotoifnilelsepop:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1986 case BRgotoifnonnilelsepop:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1987 READ_OPERAND_1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1988 /* Make program_ptr-relative */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1989 arg -= 127;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1990 do_jump:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1991 /* Record program-relative goto addresses in `jumps' table */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1992 jumps_ptr->from = icounts_ptr - icounts - argsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1993 jumps_ptr->to = jumps_ptr->from + arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1994 jumps_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1995 if (arg >= -1 && arg <= argsize)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
1996 invalid_byte_code ("goto instruction is its own target", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1997 if (arg <= SCHAR_MIN ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1998 arg > SCHAR_MAX)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1999 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2000 if (argsize == 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2001 REWRITE_OPCODE (opcode + Bgoto - BRgoto);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2002 WRITE_INT16 (arg, program_ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2003 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2004 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2005 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2006 if (argsize == 2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2007 REWRITE_OPCODE (opcode + BRgoto - Bgoto);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2008 WRITE_INT8 (arg, program_ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2009 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2010 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2011
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2012 case Bconstant2:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2013 READ_OPERAND_2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2014 WRITE_CONSTANT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2015 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2016
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2017 case BlistN:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2018 case BconcatN:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2019 case BinsertN:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2020 READ_OPERAND_1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2021 WRITE_INT8 (arg, program_ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2022 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2023
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2024 default:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2025 if (opcode < Bconstant)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2026 check_opcode (opcode);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2027 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2028 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2029 arg = opcode - Bconstant;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2030 WRITE_CONSTANT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2031 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2032 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2033 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2034 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2035
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2036 /* Fix up jumps table to refer to NEW offsets. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2037 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2038 struct jump *j;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2039 for (j = jumps; j < jumps_ptr; j++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2040 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2041 #ifdef ERROR_CHECK_BYTE_CODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2042 assert (j->from < icounts_ptr - icounts);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2043 assert (j->to < icounts_ptr - icounts);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2044 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2045 j->from = icounts[j->from];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2046 j->to = icounts[j->to];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2047 #ifdef ERROR_CHECK_BYTE_CODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2048 assert (j->from < program_ptr - program);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2049 assert (j->to < program_ptr - program);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2050 check_opcode ((Opcode) (program[j->from-1]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2051 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2052 check_opcode ((Opcode) (program[j->to]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2053 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2054 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2055
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2056 /* Fixup jumps in byte-code until no more fixups needed */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2057 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2058 int more_fixups_needed = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2059
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2060 while (more_fixups_needed)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2061 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2062 struct jump *j;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2063 more_fixups_needed = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2064 for (j = jumps; j < jumps_ptr; j++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2065 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2066 int from = j->from;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2067 int to = j->to;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2068 int jump = to - from;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2069 Opbyte *p = program + from;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2070 Opcode opcode = (Opcode) p[-1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2071 if (!more_fixups_needed)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2072 check_opcode ((Opcode) p[jump]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2073 assert (to >= 0 && program + to < program_ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2074 switch (opcode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2075 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2076 case Bgoto:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2077 case Bgotoifnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2078 case Bgotoifnonnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2079 case Bgotoifnilelsepop:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2080 case Bgotoifnonnilelsepop:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2081 WRITE_INT16 (jump, p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2082 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2083
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2084 case BRgoto:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2085 case BRgotoifnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2086 case BRgotoifnonnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2087 case BRgotoifnilelsepop:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2088 case BRgotoifnonnilelsepop:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2089 if (jump > SCHAR_MIN &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2090 jump <= SCHAR_MAX)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2091 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2092 WRITE_INT8 (jump, p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2093 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2094 else /* barf */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2095 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2096 struct jump *jj;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2097 for (jj = jumps; jj < jumps_ptr; jj++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2098 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2099 assert (jj->from < program_ptr - program);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2100 assert (jj->to < program_ptr - program);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2101 if (jj->from > from) jj->from++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2102 if (jj->to > from) jj->to++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2103 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2104 p[-1] += Bgoto - BRgoto;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2105 more_fixups_needed = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2106 memmove (p+1, p, program_ptr++ - p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2107 WRITE_INT16 (jump, p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2108 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2109 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2110
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2111 default:
2500
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
2112 ABORT();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2113 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2114 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2115 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2116 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2117 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2118
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2119 /* *program_ptr++ = 0; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2120 *program_length = program_ptr - program;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2121 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2122
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2123 /* Optimize the byte code and store the optimized program, only
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2124 understood by bytecode.c, in an opaque object in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2125 instructions slot of the Compiled_Function object. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2126 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2127 optimize_compiled_function (Lisp_Object compiled_function)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2128 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2129 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2130 int program_length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2131 int varbind_count;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2132 Opbyte *program;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2133
1737
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2134 {
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2135 int minargs = 0, maxargs = 0, totalargs = 0;
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2136 int optional_p = 0, rest_p = 0, i = 0;
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2137 {
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2138 LIST_LOOP_2 (arg, f->arglist)
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2139 {
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2140 if (EQ (arg, Qand_optional))
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2141 optional_p = 1;
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2142 else if (EQ (arg, Qand_rest))
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2143 rest_p = 1;
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2144 else
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2145 {
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2146 if (rest_p)
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2147 {
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2148 maxargs = MANY;
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2149 totalargs++;
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2150 break;
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2151 }
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2152 if (!optional_p)
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2153 minargs++;
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2154 maxargs++;
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2155 totalargs++;
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2156 }
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2157 }
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2158 }
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2159
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2160 if (totalargs)
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2161 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2162 f->arguments = make_compiled_function_args (totalargs);
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2163 #else /* not NEW_GC */
1737
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2164 f->args = xnew_array (Lisp_Object, totalargs);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2165 #endif /* not NEW_GC */
1737
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2166
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2167 {
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2168 LIST_LOOP_2 (arg, f->arglist)
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2169 {
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2170 if (!EQ (arg, Qand_optional) && !EQ (arg, Qand_rest))
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2171 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2172 XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i++] = arg;
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2173 #else /* not NEW_GC */
1737
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2174 f->args[i++] = arg;
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2175 #endif /* not NEW_GC */
1737
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2176 }
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2177 }
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2178
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2179 f->max_args = maxargs;
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2180 f->min_args = minargs;
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2181 f->args_in_array = totalargs;
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2182 }
68ed93de81b7 [xemacs-hg @ 2003-10-10 11:50:56 by stephent]
stephent
parents: 1661
diff changeset
2183
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2184 /* If we have not actually read the bytecode string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2185 and constants vector yet, fetch them from the file. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2186 if (CONSP (f->instructions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2187 Ffetch_bytecode (compiled_function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2188
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2189 if (STRINGP (f->instructions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2190 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2191 /* XSTRING_LENGTH() is more efficient than string_char_length(),
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2192 which would be slightly more `proper' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2193 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2194 optimize_byte_code (f->instructions, f->constants,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2195 program, &program_length, &varbind_count);
2500
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
2196 f->specpdl_depth = (unsigned short) (XINT (Flength (f->arglist)) +
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
2197 varbind_count);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2198 f->instructions =
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2199 make_opaque (program, program_length * sizeof (Opbyte));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2200 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2201
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2202 assert (OPAQUEP (f->instructions));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2203 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2204
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2205 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2206 /* The compiled-function object type */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2207 /************************************************************************/
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2208
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2209 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2210 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2211 int escapeflag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2212 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2213 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2214 Lisp_Compiled_Function *f =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2215 XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2216 int docp = f->flags.documentationp;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2217 int intp = f->flags.interactivep;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2218 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2219 GCPRO2 (obj, printcharfun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2220
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2221 write_c_string (printcharfun, print_readably ? "#[" : "#<compiled-function ");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2222 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2223 if (!print_readably)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2224 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2225 Lisp_Object ann = compiled_function_annotation (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2226 if (!NILP (ann))
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2227 write_fmt_string_lisp (printcharfun, "(from %S) ", 1, ann);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2228 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2229 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2230 /* COMPILED_ARGLIST = 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2231 print_internal (compiled_function_arglist (f), printcharfun, escapeflag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2232
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2233 /* COMPILED_INSTRUCTIONS = 1 */
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2234 write_c_string (printcharfun, " ");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2235 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2236 struct gcpro ngcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2237 Lisp_Object instructions = compiled_function_instructions (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2238 NGCPRO1 (instructions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2239 if (STRINGP (instructions) && !print_readably)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2240 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2241 /* We don't usually want to see that junk in the bytecode. */
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2242 write_fmt_string (printcharfun, "\"...(%ld)\"",
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2243 (long) string_char_length (instructions));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2244 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2245 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2246 print_internal (instructions, printcharfun, escapeflag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2247 NUNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2248 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2249
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2250 /* COMPILED_CONSTANTS = 2 */
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2251 write_c_string (printcharfun, " ");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2252 print_internal (compiled_function_constants (f), printcharfun, escapeflag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2253
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2254 /* COMPILED_STACK_DEPTH = 3 */
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2255 write_fmt_string (printcharfun, " %d", compiled_function_stack_depth (f));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2256
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2257 /* COMPILED_DOC_STRING = 4 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2258 if (docp || intp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2259 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2260 write_c_string (printcharfun, " ");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2261 print_internal (compiled_function_documentation (f), printcharfun,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2262 escapeflag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2263 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2264
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2265 /* COMPILED_INTERACTIVE = 5 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2266 if (intp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2267 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2268 write_c_string (printcharfun, " ");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2269 print_internal (compiled_function_interactive (f), printcharfun,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2270 escapeflag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2271 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2272
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2273 UNGCPRO;
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2274 write_c_string (printcharfun, print_readably ? "]" : ">");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2275 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2276
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2277
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2278 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2279 mark_compiled_function (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2280 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2281 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2282 int i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2283
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2284 mark_object (f->instructions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2285 mark_object (f->arglist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2286 mark_object (f->doc_and_interactive);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2287 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2288 mark_object (f->annotated);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2289 #endif
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2290 for (i = 0; i < f->args_in_array; i++)
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2291 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2292 mark_object (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i]);
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2293 #else /* not NEW_GC */
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2294 mark_object (f->args[i]);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2295 #endif /* not NEW_GC */
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2296
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2297 /* tail-recurse on constants */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2298 return f->constants;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2299 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2300
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2301 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2302 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2303 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2304 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2305 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2306 return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2307 (f1->flags.documentationp == f2->flags.documentationp &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2308 f1->flags.interactivep == f2->flags.interactivep &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2309 f1->flags.domainp == f2->flags.domainp && /* I18N3 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2310 internal_equal (compiled_function_instructions (f1),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2311 compiled_function_instructions (f2), depth + 1) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2312 internal_equal (f1->constants, f2->constants, depth + 1) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2313 internal_equal (f1->arglist, f2->arglist, depth + 1) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2314 internal_equal (f1->doc_and_interactive,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2315 f2->doc_and_interactive, depth + 1));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2316 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2317
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2318 static Hashcode
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2319 compiled_function_hash (Lisp_Object obj, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2320 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2321 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2322 return HASH3 ((f->flags.documentationp << 2) +
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2323 (f->flags.interactivep << 1) +
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2324 f->flags.domainp,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2325 internal_hash (f->instructions, depth + 1),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2326 internal_hash (f->constants, depth + 1));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2327 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2328
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1149
diff changeset
2329 static const struct memory_description compiled_function_description[] = {
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2330 { XD_INT, offsetof (Lisp_Compiled_Function, args_in_array) },
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2331 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2332 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arguments) },
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2333 #else /* not NEW_GC */
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2334 { XD_BLOCK_PTR, offsetof (Lisp_Compiled_Function, args),
2551
9f70af3ac939 [xemacs-hg @ 2005-02-03 16:14:02 by james]
james
parents: 2532
diff changeset
2335 XD_INDIRECT (0, 0), { &lisp_object_description } },
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2336 #endif /* not NEW_GC */
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2337 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) },
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2338 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) },
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2339 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) },
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2340 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2341 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2342 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2343 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2344 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2345 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2346
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 872
diff changeset
2347 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 872
diff changeset
2348 1, /*dumpable_flag*/
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 872
diff changeset
2349 mark_compiled_function,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 872
diff changeset
2350 print_compiled_function, 0,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 872
diff changeset
2351 compiled_function_equal,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 872
diff changeset
2352 compiled_function_hash,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 872
diff changeset
2353 compiled_function_description,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 872
diff changeset
2354 Lisp_Compiled_Function);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2355
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2356
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2357 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2358 Return t if OBJECT is a byte-compiled function object.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2359 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2360 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2361 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2362 return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2363 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2364
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2365 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2366 /* compiled-function object accessor functions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2367 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2368
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2369 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2370 compiled_function_arglist (Lisp_Compiled_Function *f)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2371 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2372 return f->arglist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2373 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2374
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2375 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2376 compiled_function_instructions (Lisp_Compiled_Function *f)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2377 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2378 if (! OPAQUEP (f->instructions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2379 return f->instructions;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2380
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2381 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2382 /* Invert action performed by optimize_byte_code() */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2383 Lisp_Opaque *opaque = XOPAQUE (f->instructions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2384
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
2385 Ibyte * const buffer =
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
2386 alloca_ibytes (OPAQUE_SIZE (opaque) * MAX_ICHAR_LEN);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
2387 Ibyte *bp = buffer;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2388
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2389 const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2390 const Opbyte *program_ptr = program;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2391 const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2392
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2393 while (program_ptr < program_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2394 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2395 Opcode opcode = (Opcode) READ_UINT_1;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
2396 bp += set_itext_ichar (bp, opcode);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2397 switch (opcode)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2398 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2399 case Bvarref+7:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2400 case Bvarset+7:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2401 case Bvarbind+7:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2402 case Bcall+7:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2403 case Bunbind+7:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2404 case Bconstant2:
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
2405 bp += set_itext_ichar (bp, READ_UINT_1);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
2406 bp += set_itext_ichar (bp, READ_UINT_1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2407 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2408
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2409 case Bvarref+6:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2410 case Bvarset+6:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2411 case Bvarbind+6:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2412 case Bcall+6:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2413 case Bunbind+6:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2414 case BlistN:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2415 case BconcatN:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2416 case BinsertN:
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
2417 bp += set_itext_ichar (bp, READ_UINT_1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2418 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2419
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2420 case Bgoto:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2421 case Bgotoifnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2422 case Bgotoifnonnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2423 case Bgotoifnilelsepop:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2424 case Bgotoifnonnilelsepop:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2425 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2426 int jump = READ_INT_2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2427 Opbyte buf2[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2428 Opbyte *buf2p = buf2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2429 /* Convert back to program-relative address */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2430 WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
2431 bp += set_itext_ichar (bp, buf2[0]);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
2432 bp += set_itext_ichar (bp, buf2[1]);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2433 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2434 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2435
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2436 case BRgoto:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2437 case BRgotoifnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2438 case BRgotoifnonnil:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2439 case BRgotoifnilelsepop:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2440 case BRgotoifnonnilelsepop:
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
2441 bp += set_itext_ichar (bp, READ_INT_1 + 127);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2442 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2443
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2444 default:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2445 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2446 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2447 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2448 return make_string (buffer, bp - buffer);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2449 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2450 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2451
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2452 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2453 compiled_function_constants (Lisp_Compiled_Function *f)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2454 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2455 return f->constants;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2456 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2457
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2458 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2459 compiled_function_stack_depth (Lisp_Compiled_Function *f)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2460 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2461 return f->stack_depth;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2462 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2463
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2464 /* The compiled_function->doc_and_interactive slot uses the minimal
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2465 number of conses, based on compiled_function->flags; it may take
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2466 any of the following forms:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2467
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2468 doc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2469 interactive
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2470 domain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2471 (doc . interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2472 (doc . domain)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2473 (interactive . domain)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2474 (doc . (interactive . domain))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2475 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2476
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2477 /* Caller must check flags.interactivep first */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2478 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2479 compiled_function_interactive (Lisp_Compiled_Function *f)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2480 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2481 assert (f->flags.interactivep);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2482 if (f->flags.documentationp && f->flags.domainp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2483 return XCAR (XCDR (f->doc_and_interactive));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2484 else if (f->flags.documentationp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2485 return XCDR (f->doc_and_interactive);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2486 else if (f->flags.domainp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2487 return XCAR (f->doc_and_interactive);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2488 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2489 return f->doc_and_interactive;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2490 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2491
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2492 /* Caller need not check flags.documentationp first */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2493 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2494 compiled_function_documentation (Lisp_Compiled_Function *f)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2495 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2496 if (! f->flags.documentationp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2497 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2498 else if (f->flags.interactivep && f->flags.domainp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2499 return XCAR (f->doc_and_interactive);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2500 else if (f->flags.interactivep)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2501 return XCAR (f->doc_and_interactive);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2502 else if (f->flags.domainp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2503 return XCAR (f->doc_and_interactive);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2504 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2505 return f->doc_and_interactive;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2506 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2507
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2508 /* Caller need not check flags.domainp first */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2509 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2510 compiled_function_domain (Lisp_Compiled_Function *f)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2511 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2512 if (! f->flags.domainp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2513 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2514 else if (f->flags.documentationp && f->flags.interactivep)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2515 return XCDR (XCDR (f->doc_and_interactive));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2516 else if (f->flags.documentationp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2517 return XCDR (f->doc_and_interactive);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2518 else if (f->flags.interactivep)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2519 return XCDR (f->doc_and_interactive);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2520 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2521 return f->doc_and_interactive;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2522 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2523
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2524 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2525
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2526 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2527 compiled_function_annotation (Lisp_Compiled_Function *f)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2528 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2529 return f->annotated;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2530 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2531
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2532 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2533
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2534 /* used only by Snarf-documentation; there must be doc already. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2535 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2536 set_compiled_function_documentation (Lisp_Compiled_Function *f,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2537 Lisp_Object new_doc)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2538 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2539 assert (f->flags.documentationp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2540 assert (INTP (new_doc) || STRINGP (new_doc));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2541
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2542 if (f->flags.interactivep && f->flags.domainp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2543 XCAR (f->doc_and_interactive) = new_doc;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2544 else if (f->flags.interactivep)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2545 XCAR (f->doc_and_interactive) = new_doc;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2546 else if (f->flags.domainp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2547 XCAR (f->doc_and_interactive) = new_doc;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2548 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2549 f->doc_and_interactive = new_doc;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2550 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2551
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2552
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2553 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2554 Return the argument list of the compiled-function object FUNCTION.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2555 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2556 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2557 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2558 CHECK_COMPILED_FUNCTION (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2559 return compiled_function_arglist (XCOMPILED_FUNCTION (function));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2560 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2561
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2562 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2563 Return the byte-opcode string of the compiled-function object FUNCTION.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2564 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2565 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2566 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2567 CHECK_COMPILED_FUNCTION (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2568 return compiled_function_instructions (XCOMPILED_FUNCTION (function));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2569 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2570
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2571 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2572 Return the constants vector of the compiled-function object FUNCTION.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2573 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2574 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2575 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2576 CHECK_COMPILED_FUNCTION (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2577 return compiled_function_constants (XCOMPILED_FUNCTION (function));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2578 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2579
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2580 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2581 Return the maximum stack depth of the compiled-function object FUNCTION.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2582 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2583 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2584 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2585 CHECK_COMPILED_FUNCTION (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2586 return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2587 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2588
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2589 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2590 Return the doc string of the compiled-function object FUNCTION, if available.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2591 Functions that had their doc strings snarfed into the DOC file will have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2592 an integer returned instead of a string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2593 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2594 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2595 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2596 CHECK_COMPILED_FUNCTION (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2597 return compiled_function_documentation (XCOMPILED_FUNCTION (function));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2598 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2599
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2600 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2601 Return the interactive spec of the compiled-function object FUNCTION, or nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2602 If non-nil, the return value will be a list whose first element is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2603 `interactive' and whose second element is the interactive spec.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2604 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2605 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2606 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2607 CHECK_COMPILED_FUNCTION (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2608 return XCOMPILED_FUNCTION (function)->flags.interactivep
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2609 ? list2 (Qinteractive,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2610 compiled_function_interactive (XCOMPILED_FUNCTION (function)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2611 : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2612 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2613
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2614 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2615
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2616 DEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2617 Return the annotation of the compiled-function object FUNCTION, or nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2618 The annotation is a piece of information indicating where this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2619 compiled-function object came from. Generally this will be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2620 a symbol naming a function; or a string naming a file, if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2621 compiled-function object was not defined in a function; or nil,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2622 if the compiled-function object was not created as a result of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2623 a `load'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2624 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2625 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2626 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2627 CHECK_COMPILED_FUNCTION (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2628 return compiled_function_annotation (XCOMPILED_FUNCTION (function));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2629 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2630
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2631 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2632
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2633 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2634 Return the domain of the compiled-function object FUNCTION, or nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2635 This is only meaningful if I18N3 was enabled when emacs was compiled.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2636 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2637 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2638 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2639 CHECK_COMPILED_FUNCTION (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2640 return XCOMPILED_FUNCTION (function)->flags.domainp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2641 ? compiled_function_domain (XCOMPILED_FUNCTION (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2642 : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2643 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2644
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2645
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2646
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2647 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2648 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2649 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2650 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2651 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2652 Lisp_Compiled_Function *f;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2653 CHECK_COMPILED_FUNCTION (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2654 f = XCOMPILED_FUNCTION (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2655
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2656 if (OPAQUEP (f->instructions) || STRINGP (f->instructions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2657 return function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2658
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2659 if (CONSP (f->instructions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2660 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2661 Lisp_Object tem = read_doc_string (f->instructions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2662 if (!CONSP (tem))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
2663 signal_error (Qinvalid_byte_code,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
2664 "Invalid lazy-loaded byte code", tem);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2665 /* v18 or v19 bytecode file. Need to Ebolify. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2666 if (f->flags.ebolified && VECTORP (XCDR (tem)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2667 ebolify_bytecode_constants (XCDR (tem));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2668 f->instructions = XCAR (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2669 f->constants = XCDR (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2670 return function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2671 }
2500
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
2672 ABORT ();
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
2673 return Qnil; /* not (usually) reached */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2674 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2675
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2676 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2677 Convert compiled function FUNCTION into an optimized internal form.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2678 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2679 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2680 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2681 Lisp_Compiled_Function *f;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2682 CHECK_COMPILED_FUNCTION (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2683 f = XCOMPILED_FUNCTION (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2684
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2685 if (OPAQUEP (f->instructions)) /* Already optimized? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2686 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2687
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2688 optimize_compiled_function (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2689 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2690 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2691
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2692 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2693 Function used internally in byte-compiled code.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2694 First argument INSTRUCTIONS is a string of byte code.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2695 Second argument CONSTANTS is a vector of constants.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2696 Third argument STACK-DEPTH is the maximum stack depth used in this function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2697 If STACK-DEPTH is incorrect, Emacs may crash.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2698 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2699 (instructions, constants, stack_depth))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2700 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2701 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2702 int varbind_count;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2703 int program_length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2704 Opbyte *program;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2705
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2706 CHECK_STRING (instructions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2707 CHECK_VECTOR (constants);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2708 CHECK_NATNUM (stack_depth);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2709
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2710 /* Optimize the `instructions' string, just like when executing a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2711 regular compiled function, but don't save it for later since this is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2712 likely to only be executed once. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2713 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2714 optimize_byte_code (instructions, constants, program,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2715 &program_length, &varbind_count);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2716 SPECPDL_RESERVE (varbind_count);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2717 return execute_optimized_program (program,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2718 XINT (stack_depth),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2719 XVECTOR_DATA (constants));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2720 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2721
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2722
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2723 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2724 syms_of_bytecode (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2725 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2726 INIT_LRECORD_IMPLEMENTATION (compiled_function);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2727 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2728 INIT_LRECORD_IMPLEMENTATION (compiled_function_args);
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 2720
diff changeset
2729 #endif /* NEW_GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2730
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2731 DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state);
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
2732 DEFSYMBOL (Qbyte_code);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
2733 DEFSYMBOL_MULTIWORD_PREDICATE (Qcompiled_functionp);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2734
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2735 DEFSUBR (Fbyte_code);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2736 DEFSUBR (Ffetch_bytecode);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2737 DEFSUBR (Foptimize_compiled_function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2738
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2739 DEFSUBR (Fcompiled_function_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2740 DEFSUBR (Fcompiled_function_instructions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2741 DEFSUBR (Fcompiled_function_constants);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2742 DEFSUBR (Fcompiled_function_stack_depth);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2743 DEFSUBR (Fcompiled_function_arglist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2744 DEFSUBR (Fcompiled_function_interactive);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2745 DEFSUBR (Fcompiled_function_doc_string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2746 DEFSUBR (Fcompiled_function_domain);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2747 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2748 DEFSUBR (Fcompiled_function_annotation);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2749 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2750
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2751 #ifdef BYTE_CODE_METER
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 444
diff changeset
2752 DEFSYMBOL (Qbyte_code_meter);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2753 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2754 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2755
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2756 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2757 vars_of_bytecode (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2758 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2759 #ifdef BYTE_CODE_METER
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2760
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2761 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2762 A vector of vectors which holds a histogram of byte code usage.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2763 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2764 opcode CODE has been executed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2765 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2766 indicates how many times the byte opcodes CODE1 and CODE2 have been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2767 executed in succession.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2768 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2769 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2770 If non-nil, keep profiling information on byte code usage.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2771 The variable `byte-code-meter' indicates how often each byte opcode is used.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2772 If a symbol has a property named `byte-code-meter' whose value is an
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2773 integer, it is incremented each time that symbol's function is called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2774 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2775
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2776 byte_metering_on = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2777 Vbyte_code_meter = make_vector (256, Qzero);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2778 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2779 int i = 256;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2780 while (i--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2781 XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2782 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2783 #endif /* BYTE_CODE_METER */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2784 }