Mercurial > hg > xemacs-beta
annotate src/bytecode.c @ 5353:38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
lisp/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el:
* bytecomp.el (byte-compile-initial-macro-environment):
Shadow `block', `return-from' here, we implement them differently
when byte-compiling.
* bytecomp.el (byte-compile-active-blocks): New.
* bytecomp.el (byte-compile-block-1): New.
* bytecomp.el (byte-compile-return-from-1): New.
* bytecomp.el (return-from-1): New.
* bytecomp.el (block-1): New.
These are two aliases that exist to have their own associated
byte-compile functions, which functions implement `block' and
`return-from'.
* cl-extra.el (cl-macroexpand-all):
Fix a bug here when macros in the environment have been compiled.
* cl-macs.el (block):
* cl-macs.el (return):
* cl-macs.el (return-from):
Be more careful about lexical scope in these macros.
* cl.el:
* cl.el ('cl-block-wrapper): Removed.
* cl.el ('cl-block-throw): Removed.
These aren't needed in code generated by this XEmacs. They
shouldn't be needed in code generated by XEmacs 21.4, but if it
turns out the packages do need them, we can put them back.
2011-01-30 Mike Sperber <mike@xemacs.org>
* font-lock.el (font-lock-fontify-pending-extents): Don't fail if
`font-lock-mode' is unset, which can happen in the middle of
`revert-buffer'.
2011-01-23 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete):
* cl-macs.el (delq):
* cl-macs.el (remove):
* cl-macs.el (remq):
Don't use the compiler macro if these functions were given the
wrong number of arguments, as happens in lisp-tests.el.
* cl-seq.el (remove, remq): Removed.
I added these to subr.el, and forgot to remove them from here.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-setq, byte-compile-set):
Remove kludge allowing keywords' values to be set, all the code
that does that is gone.
* cl-compat.el (elt-satisfies-test-p):
* faces.el (set-face-parent):
* faces.el (face-doc-string):
* gtk-font-menu.el:
* gtk-font-menu.el (gtk-reset-device-font-menus):
* msw-font-menu.el:
* msw-font-menu.el (mswindows-reset-device-font-menus):
* package-get.el (package-get-installedp):
* select.el (select-convert-from-image-data):
* sound.el:
* sound.el (load-sound-file):
* x-font-menu.el (x-reset-device-font-menus-core):
Don't quote keywords, they're self-quoting, and the
win from backward-compatibility is sufficiently small now that the
style problem overrides it.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (block, return-from): Require that NAME be a symbol
in these macros, as always documented in the #'block docstring and
as required by Common Lisp.
* descr-text.el (unidata-initialize-unihan-database):
Correct the use of non-symbols in #'block and #'return-from in
this function.
2011-01-15 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (concatenate): Accept more complicated TYPEs in this
function, handing the sequences over to #'coerce if we don't
understand them here.
* cl-macs.el (inline): Don't proclaim #'concatenate as inline, its
compiler macro is more useful than doing that.
2011-01-11 Aidan Kehoe <kehoea@parhasard.net>
* subr.el (delete, delq, remove, remq): Move #'remove, #'remq
here, they don't belong in cl-seq.el; move #'delete, #'delq here
from fns.c, implement them in terms of #'delete*, allowing support
for sequences generally.
* update-elc.el (do-autoload-commands): Use #'delete*, not #'delq
here, now the latter's no longer dumped.
* cl-macs.el (delete, delq): Add compiler macros transforming
#'delete and #'delq to #'delete* calls.
2011-01-10 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box): Correct a misplaced parenthesis
here, thank you Mats Lidell in 87zkr9gqrh.fsf@mail.contactor.se !
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box):
* list-mode.el (display-completion-list):
These functions used to use cl-parsing-keywords; change them to
use defun* instead, fixing the build. (Not sure what led to me
not including this change in d1b17a33450b!)
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (define-star-compiler-macros):
Make sure the form has ITEM and LIST specified before attempting
to change to calls with explicit tests; necessary for some tests
in lisp-tests.el to compile correctly.
(stable-union, stable-intersection): Add compiler macros for these
functions, in the same way we do for most of the other functions
in cl-seq.el.
2011-01-01 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (dolist, dotimes, do-symbols, macrolet)
(symbol-macrolet):
Define these macros with defmacro* instead of parsing the argument
list by hand, for the sake of style and readability; use backquote
where appropriate, instead of calling #'list and and friends, for
the same reason.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* x-misc.el (device-x-display):
Provide this function, documented in the Lispref for years, but
not existing previously. Thank you Julian Bradfield, thank you
Jeff Mincy.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl-seq.el:
Move the heavy lifting from this file to C. Dump the
cl-parsing-keywords macro, but don't use defun* for the functions
we define that do take keywords, dynamic scope lossage makes that
not practical.
* subr.el (sort, fillarray): Move these aliases here.
(map-plist): #'nsublis is now built-in, but at this point #'eql
isn't necessarily available as a test; use #'eq.
* obsolete.el (cl-delete-duplicates): Make this available for old
compiler macros and old code.
(memql): Document that this is equivalent to #'member*, and worse.
* cl.el (adjoin, subst): Removed. These are in C.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* simple.el (assoc-ignore-case): Remove a duplicate definition of
this function (it's already in subr.el).
* iso8859-1.el (char-width):
On non-Mule, make this function equivalent to that produced by
(constantly 1), but preserve its docstring.
* subr.el (subst-char-in-string): Define this in terms of
#'substitute, #'nsubstitute.
(string-width): Define this using #'reduce and #'char-width.
(char-width): Give this a simpler definition, it makes far more
sense to check for mule at load time and redefine, as we do in
iso8859-1.el.
(store-substring): Implement this in terms of #'replace, now
#'replace is cheap.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* update-elc.el (lisp-files-needed-for-byte-compilation)
(lisp-files-needing-early-byte-compilation):
cl-macs belongs in the former, not the latter, it is as
fundamental as bytecomp.el.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl.el:
Provde the Common Lisp program-error, type-error as error
symbols. This doesn't nearly go far enough for anyone using the
Common Lisp errors.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete-duplicates):
If the form has an incorrect number of arguments, don't attempt a
compiler macroexpansion.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (cl-safe-expr-p):
Forms that start with the symbol lambda are also safe.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
For these functions' compiler macros, the optimisation is safe
even if the first and the last arguments have side effects, since
they're only used the once.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (inline-side-effect-free-compiler-macros):
Unroll a loop here at macro-expansion time, so these compiler
macros are compiled. Use #'eql instead of #'eq in a couple of
places for better style.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (notany, notevery): Avoid some dynamic scope
stupidity with local variable names in these functions, when they
weren't prefixed with cl-; go into some more detail in the doc
strings.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns): #'remove, #'remq are
free of side-effects.
(side-effect-and-error-free-fns):
Drop dot, dot-marker from the list.
2010-11-17 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (coerce):
In the argument list, name the first argument OBJECT, not X; the
former name was always used in the doc string and is clearer.
Handle vector type specifications which include the length of the
target sequence, error if there's a mismatch.
* cl-macs.el (cl-make-type-test): Handle type specifications
starting with the symbol 'eql.
2010-11-14 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (eql): Don't remove the byte-compile property of this
symbol. That was necessary to override a bug in bytecomp.el where
#'eql was confused with #'eq, which bug we no longer have.
If neither expression is constant, don't attempt to handle the
expression in this compiler macro, leave it to byte-compile-eql,
which produces better code anyway.
* bytecomp.el (eq): #'eql is not the function associated with the
byte-eq byte code.
(byte-compile-eql): Add an explicit compile method for this
function, for cases where the cl-macs compiler macro hasn't
reduced it to #'eq or #'equal.
2010-10-25 Aidan Kehoe <kehoea@parhasard.net>
Add compiler macros and compilation sanity-checking for various
functions that take keywords.
* byte-optimize.el (side-effect-free-fns): #'symbol-value is
side-effect free and not error free.
* bytecomp.el (byte-compile-normal-call): Check keyword argument
lists for sanity; store information about the positions where
keyword arguments start using the new byte-compile-keyword-start
property.
* cl-macs.el (cl-const-expr-val): Take a new optional argument,
cl-not-constant, defaulting to nil, in this function; return it if
the expression is not constant.
(cl-non-fixnum-number-p): Make this into a separate function, we
want to pass it to #'every.
(eql): Use it.
(define-star-compiler-macros): Use the same code to generate the
member*, assoc* and rassoc* compiler macros; special-case some
code in #'add-to-list in subr.el.
(remove, remq): Add compiler macros for these two functions, in
preparation for #'remove being in C.
(define-foo-if-compiler-macros): Transform (remove-if-not ...) calls to
(remove ... :if-not) at compile time, which will be a real win
once the latter is in C.
(define-substitute-if-compiler-macros)
(define-subst-if-compiler-macros): Similarly for these functions.
(delete-duplicates): Change this compiler macro to use
#'plists-equal; if we don't have information about the type of
SEQUENCE at compile time, don't bother attempting to inline the
call, the function will be in C soon enough.
(equalp): Remove an old commented-out compiler macro for this, if
we want to see it it's in version control.
(subst-char-in-string): Transform this to a call to nsubstitute or
nsubstitute, if that is appropriate.
* cl.el (ldiff): Don't call setf here, this makes for a load-time
dependency problem in cl-macs.el
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* term/vt100.el:
Refer to XEmacs, not GNU Emacs, in permissions.
* term/bg-mouse.el:
* term/sup-mouse.el:
Put copyright notice in canonical "Copyright DATE AUTHOR" form.
Refer to XEmacs, not GNU Emacs, in permissions.
* site-load.el:
Add permission boilerplate.
* mule/canna-leim.el:
* alist.el:
Refer to XEmacs, not APEL/this program, in permissions.
* mule/canna-leim.el:
Remove my copyright, I've assigned it to the FSF.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* gtk.el:
* gtk-widget-accessors.el:
* gtk-package.el:
* gtk-marshal.el:
* gtk-compose.el:
* gnome.el:
Add copyright notice based on internal evidence.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* easymenu.el: Add reference to COPYING to permission notice.
* gutter.el:
* gutter-items.el:
* menubar-items.el:
Fix typo "Xmacs" in permissions notice.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* auto-save.el:
* font.el:
* fontconfig.el:
* mule/kinsoku.el:
Add "part of XEmacs" text to permission notice.
2010-10-14 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns):
* cl-macs.el (remf, getf):
* cl-extra.el (tailp, cl-set-getf, cl-do-remf):
* cl.el (ldiff, endp):
Tighten up Common Lisp compatibility for #'ldiff, #'endp, #'tailp;
add circularity checking for the first two.
#'cl-set-getf and #'cl-do-remf were Lisp implementations of
#'plist-put and #'plist-remprop; change the names to aliases,
changes the macros that use them to using #'plist-put and
#'plist-remprop directly.
2010-10-12 Aidan Kehoe <kehoea@parhasard.net>
* abbrev.el (fundamental-mode-abbrev-table, global-abbrev-table):
Create both these abbrev tables using the usual
#'define-abbrev-table calls, rather than attempting to
special-case them.
* cl-extra.el: Force cl-macs to be loaded here, if cl-extra.el is
being loaded interpreted. Previously other, later files would
redundantly call (load "cl-macs") when interpreted, it's more
reasonable to do it here, once.
* cmdloop.el (read-quoted-char-radix): Use defcustom here, we
don't have any dump-order dependencies that would prevent that.
* custom.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling, rely on cl-extra.el in the
former case and the appropriate entry in bytecomp-load-hook in the
latter. Get rid of custom-declare-variable-list, we have no
dump-time dependencies that would require it.
* faces.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling.
* packages.el: Remove some inaccurate comments.
* post-gc.el (cleanup-simple-finalizers): Use #'delete-if-not
here, now the order of preloaded-file-list has been changed to
make it available.
* subr.el (custom-declare-variable-list): Remove. No need for it.
Also remove a stub define-abbrev-table from this file, given the
current order of preloaded-file-list there's no need for it.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-constp) Forms quoted with FUNCTION are
also constant.
(byte-compile-initial-macro-environment): In #'the, if FORM is
constant and does not match TYPE, warn at byte-compile time.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* backquote.el (bq-vector-contents, bq-list*): Remove; the former
is equivalent to (append VECTOR nil), the latter to (list* ...).
(bq-process-2): Use (append VECTOR nil) instead of using
#'bq-vector-contents to convert to a list.
(bq-process-1): Now we use list* instead of bq-list
* subr.el (list*): Moved from cl.el, since it is now required to
be available the first time a backquoted form is encountered.
* cl.el (list*): Move to subr.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* test-harness.el (Check-Message):
Add an omitted comma here, thank you the buildbot.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* hash-table.el (hash-table-key-list, hash-table-value-list)
(hash-table-key-value-alist, hash-table-key-value-plist):
Remove some useless #'nreverse calls in these files; our hash
tables have no order, it's not helpful to pretend they do.
* behavior.el (read-behavior):
Do the same in this file, in some code evidently copied from
hash-table.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* info.el (Info-insert-dir):
* format.el (format-deannotate-region):
* files.el (cd, save-buffers-kill-emacs):
Use #'some, #'every and related functions for applying boolean
operations to lists, instead of rolling our own ones that cons and
don't short-circuit.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
* cl-macs.el (the):
Rephrase the docstring, make its implementation when compiling
files a little nicer.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* descr-text.el (unidata-initialize-unicodedata-database)
(unidata-initialize-unihan-database, describe-char-unicode-data)
(describe-char-unicode-data):
Wrap calls to the database functions with (with-fboundp ...),
avoiding byte compile warnings on builds without support for the
database functions.
(describe-char): (reduce #'max ...), not (apply #'max ...), no
need to cons needlessly.
(describe-char): Remove a redundant lambda wrapping
#'extent-properties.
(describe-char-unicode-data): Call #'nsubst when replacing "" with
nil in the result of #'split-string, instead of consing inside
mapcar.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* x-faces.el (x-available-font-sizes):
* specifier.el (let-specifier):
* package-ui.el (pui-add-required-packages):
* msw-faces.el (mswindows-available-font-sizes):
* modeline.el (modeline-minor-mode-menu):
* minibuf.el (minibuf-directory-files):
Replace the O2N (delq nil (mapcar (lambda (W) (and X Y)) Z)) with
the ON (mapcan (lambda (W) (and X (list Y))) Z) in these files.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
When these functions are handed more than two arguments, and those
arguments have no side effects, transform to a series of two
argument calls, avoiding funcall in the byte-compiled code.
* mule/mule-cmds.el (finish-set-language-environment):
Take advantage of this change in a function called 256 times at
startup.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-function-form, byte-compile-quote)
(byte-compile-quote-form):
Warn at compile time, and error at runtime, if a (quote ...) or a
(function ...) form attempts to quote more than one object.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
(mapcar ...)) to (mapcan ...); warn about use of the first idiom.
* update-elc.el (do-autoload-commands):
* packages.el (packages-find-package-library-path):
* frame.el (frame-list):
* extents.el (extent-descendants):
* etags.el (buffer-tag-table-files):
* dumped-lisp.el (preloaded-file-list):
* device.el (device-list):
* bytecomp-runtime.el (proclaim-inline, proclaim-notinline)
Use #'mapcan, not (apply #'nconc (mapcar ...) in all these files.
* bytecomp-runtime.el (eval-when-compile, eval-and-compile):
In passing, mention that these macros also evaluate the body when
interpreted.
tests/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Test lexical scope for `block', `return-from'; add a
Known-Bug-Expect-Failure for a contorted example that fails when
byte-compiled.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 07 Feb 2011 12:01:24 +0000 |
| parents | c096d8051f89 |
| children | 4c4b96b13f70 8d29f1c4bb98 |
| rev | line source |
|---|---|
| 428 | 1 /* Execution of byte code produced by bytecomp.el. |
| 2 Implementation of compiled-function objects. | |
| 3 Copyright (C) 1992, 1993 Free Software Foundation, Inc. | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
4 Copyright (C) 1995, 2002, 2010 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: Mule 2.0, FSF 19.30. */ | |
| 24 | |
| 25 /* This file has been Mule-ized. */ | |
| 26 | |
| 27 | |
| 28 /* Authorship: | |
| 29 | |
| 30 FSF: long ago. | |
| 31 | |
| 32 hacked on by jwz@jwz.org 1991-06 | |
| 33 o added a compile-time switch to turn on simple sanity checking; | |
| 34 o put back the obsolete byte-codes for error-detection; | |
| 35 o added a new instruction, unbind_all, which I will use for | |
| 36 tail-recursion elimination; | |
| 37 o made temp_output_buffer_show be called with the right number | |
| 38 of args; | |
| 39 o made the new bytecodes be called with args in the right order; | |
| 40 o added metering support. | |
| 41 | |
| 42 by Hallvard: | |
| 43 o added relative jump instructions; | |
| 44 o all conditionals now only do QUIT if they jump. | |
| 45 | |
| 46 Ben Wing: some changes for Mule, 1995-06. | |
| 47 | |
| 48 Martin Buchholz: performance hacking, 1998-09. | |
| 49 See Internals Manual, Evaluation. | |
| 50 */ | |
| 51 | |
| 52 #include <config.h> | |
| 53 #include "lisp.h" | |
| 54 #include "backtrace.h" | |
| 55 #include "buffer.h" | |
| 56 #include "bytecode.h" | |
| 57 #include "opaque.h" | |
| 58 #include "syntax.h" | |
| 872 | 59 #include "window.h" |
| 428 | 60 |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
61 #define NUM_REMEMBERED_BYTE_OPS 100 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
62 |
| 3092 | 63 #ifdef NEW_GC |
| 64 static Lisp_Object | |
| 65 make_compiled_function_args (int totalargs) | |
| 66 { | |
| 67 Lisp_Compiled_Function_Args *args; | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
68 args = XCOMPILED_FUNCTION_ARGS |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
69 (ALLOC_SIZED_LISP_OBJECT |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
70 (FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
71 Lisp_Object, args, totalargs), |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
72 compiled_function_args)); |
| 3092 | 73 args->size = totalargs; |
| 74 return wrap_compiled_function_args (args); | |
| 75 } | |
| 76 | |
| 77 static Bytecount | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
78 size_compiled_function_args (Lisp_Object obj) |
| 3092 | 79 { |
| 80 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args, | |
| 81 Lisp_Object, args, | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
82 XCOMPILED_FUNCTION_ARGS (obj)->size); |
| 3092 | 83 } |
| 84 | |
| 85 static const struct memory_description compiled_function_args_description[] = { | |
| 86 { XD_LONG, offsetof (Lisp_Compiled_Function_Args, size) }, | |
| 87 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Compiled_Function_Args, args), | |
| 88 XD_INDIRECT(0, 0) }, | |
| 89 { XD_END } | |
| 90 }; | |
| 91 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
92 DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT ("compiled-function-args", |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
93 compiled_function_args, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
94 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
95 compiled_function_args_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
96 size_compiled_function_args, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
97 Lisp_Compiled_Function_Args); |
| 3092 | 98 #endif /* NEW_GC */ |
| 99 | |
| 428 | 100 EXFUN (Ffetch_bytecode, 1); |
| 101 | |
| 102 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code; | |
| 103 | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
104 |
| 428 | 105 enum Opcode /* Byte codes */ |
| 106 { | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
107 #define OPCODE(sym, val) B##sym = val, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
108 #include "bytecode-ops.h" |
| 428 | 109 }; |
| 110 typedef enum Opcode Opcode; | |
| 111 | |
| 112 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr, | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
113 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
114 Lisp_Object *stack_beg, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
115 Lisp_Object *stack_end, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
116 #endif /* ERROR_CHECK_BYTE_CODE */ |
| 442 | 117 const Opbyte *program_ptr, |
| 428 | 118 Opcode opcode); |
| 119 | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
120 #ifndef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
121 |
|
4974
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
122 /* Normally we would use `x' instead of `0' in the argument list, to avoid |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
123 problems if `x' (an expression) has side effects, and warnings if `x' |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
124 contains variables or parameters that are otherwise unused. But in |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
125 this case `x' contains references to vars and params that exist only |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
126 when ERROR_CHECK_BYTE_CODE, and leaving in `x' would result in compile |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
127 errors. */ |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
128 # define bytecode_assert(x) disabled_assert (0) |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
129 # define bytecode_assert_with_message(x, msg) disabled_assert(0) |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
130 # define bytecode_abort_with_message(msg) abort_with_message (msg) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
131 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
132 #else /* ERROR_CHECK_BYTE_CODE */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
133 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
134 # define bytecode_assert(x) \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
135 ((x) ? (void) 0 : assert_failed_with_remembered_ops (__FILE__, __LINE__, #x)) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
136 # define bytecode_assert_with_message(x, msg) \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
137 ((x) ? (void) 0 : assert_failed_with_remembered_ops (__FILE__, __LINE__, msg)) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
138 # define bytecode_abort_with_message(msg) \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
139 assert_failed_with_remembered_ops (__FILE__, __LINE__, msg) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
140 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
141 /* Table mapping opcodes to their names. This handles opcodes like |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
142 Bvarref+7, but it doesn't list any of the Bconstant+N opcodes; those |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
143 are handled specially. */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
144 Ascbyte *opcode_name_table[256]; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
145 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
146 /* Circular queue remembering the most recent operations. */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
147 Opcode remembered_ops[NUM_REMEMBERED_BYTE_OPS]; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
148 int remembered_op_next_pos, num_remembered; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
149 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
150 static void |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
151 remember_operation (Opcode op) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
152 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
153 remembered_ops[remembered_op_next_pos] = op; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
154 remembered_op_next_pos = |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
155 (remembered_op_next_pos + 1) % NUM_REMEMBERED_BYTE_OPS; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
156 if (num_remembered < NUM_REMEMBERED_BYTE_OPS) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
157 num_remembered++; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
158 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
159 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
160 static void |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
161 assert_failed_with_remembered_ops (const Ascbyte *file, int line, |
| 4970 | 162 const Ascbyte *msg_to_abort_with) |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
163 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
164 Ascbyte *msg = |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
165 alloca_array (Ascbyte, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
166 NUM_REMEMBERED_BYTE_OPS*50 + strlen (msg_to_abort_with)); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
167 int i; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
168 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
169 if (msg_to_abort_with) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
170 strcpy (msg, msg_to_abort_with); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
171 strcat (msg, "\n\nRecent bytecodes, oldest first:\n\n"); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
172 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
173 for (i = 0; i < num_remembered; i++) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
174 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
175 Ascbyte msg2[50]; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
176 int pos; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
177 Opcode op; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
178 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
179 sprintf (msg2, "%5d: ", i - num_remembered + 1); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
180 strcat (msg, msg2); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
181 pos = (remembered_op_next_pos + NUM_REMEMBERED_BYTE_OPS + |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
182 i - num_remembered) % NUM_REMEMBERED_BYTE_OPS; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
183 op = remembered_ops[pos]; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
184 if (op >= Bconstant) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
185 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
186 sprintf (msg2, "constant+%d", op - Bconstant); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
187 strcat (msg, msg2); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
188 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
189 else |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
190 { |
| 4970 | 191 const Ascbyte *opname = opcode_name_table[op]; |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
192 if (!opname) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
193 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
194 stderr_out ("Internal error! NULL pointer in opcode_name_table, opcode %d\n", op); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
195 strcat (msg, "NULL"); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
196 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
197 else |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
198 strcat (msg, opname); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
199 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
200 sprintf (msg2, " (%d)\n", op); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
201 strcat (msg, msg2); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
202 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
203 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
204 assert_failed (file, line, msg); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
205 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
206 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
207 #endif /* ERROR_CHECK_BYTE_CODE */ |
| 428 | 208 |
| 209 | |
| 210 #ifdef BYTE_CODE_METER | |
| 211 | |
| 212 Lisp_Object Vbyte_code_meter, Qbyte_code_meter; | |
| 213 int byte_metering_on; | |
| 214 | |
| 215 static void | |
| 216 meter_code (Opcode prev_opcode, Opcode this_opcode) | |
| 217 { | |
| 218 if (byte_metering_on) | |
| 219 { | |
| 220 Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]); | |
| 221 p[0] = INT_PLUS1 (p[0]); | |
| 222 if (prev_opcode) | |
| 223 p[prev_opcode] = INT_PLUS1 (p[prev_opcode]); | |
| 224 } | |
| 225 } | |
| 226 | |
| 227 #endif /* BYTE_CODE_METER */ | |
| 228 | |
| 229 | |
| 230 static Lisp_Object | |
| 231 bytecode_negate (Lisp_Object obj) | |
| 232 { | |
| 233 retry: | |
| 234 | |
| 1983 | 235 if (INTP (obj)) return make_integer (- XINT (obj)); |
| 428 | 236 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj)); |
| 1983 | 237 if (CHARP (obj)) return make_integer (- ((int) XCHAR (obj))); |
| 238 if (MARKERP (obj)) return make_integer (- ((int) marker_position (obj))); | |
| 239 #ifdef HAVE_BIGNUM | |
| 240 if (BIGNUMP (obj)) BIGNUM_ARITH_RETURN (obj, neg); | |
| 241 #endif | |
| 242 #ifdef HAVE_RATIO | |
| 243 if (RATIOP (obj)) RATIO_ARITH_RETURN (obj, neg); | |
| 244 #endif | |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
245 #ifdef HAVE_BIGFLOAT |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
246 if (BIGFLOATP (obj)) BIGFLOAT_ARITH_RETURN (obj, neg); |
| 1983 | 247 #endif |
| 428 | 248 |
| 249 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); | |
| 250 goto retry; | |
| 251 } | |
| 252 | |
| 253 static Lisp_Object | |
|
5300
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
254 bytecode_nreverse (Lisp_Object sequence) |
| 428 | 255 { |
|
5300
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
256 if (LISTP (sequence)) |
| 428 | 257 { |
|
5300
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
258 REGISTER Lisp_Object prev = Qnil; |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
259 REGISTER Lisp_Object tail = sequence; |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
260 |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
261 while (!NILP (tail)) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
262 { |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
263 REGISTER Lisp_Object next; |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
264 CHECK_CONS (tail); |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
265 next = XCDR (tail); |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
266 XCDR (tail) = prev; |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
267 prev = tail; |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
268 tail = next; |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
269 } |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
270 return prev; |
| 428 | 271 } |
|
5300
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
272 else |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
273 { |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
274 return Fnreverse (sequence); |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5206
diff
changeset
|
275 } |
| 428 | 276 } |
| 277 | |
| 278 | |
| 279 /* We have our own two-argument versions of various arithmetic ops. | |
| 280 Only two-argument arithmetic operations have their own byte codes. */ | |
|
4910
6bc1f3f6cf0d
Make canoncase visible to Lisp; use it with chars in internal_equalp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
281 int |
| 428 | 282 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2) |
| 283 { | |
| 1983 | 284 #ifdef WITH_NUMBER_TYPES |
| 285 switch (promote_args (&obj1, &obj2)) | |
| 286 { | |
| 287 case FIXNUM_T: | |
| 288 { | |
| 289 EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2); | |
| 290 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0; | |
| 291 } | |
| 292 #ifdef HAVE_BIGNUM | |
| 293 case BIGNUM_T: | |
| 294 return bignum_cmp (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); | |
| 295 #endif | |
| 296 #ifdef HAVE_RATIO | |
| 297 case RATIO_T: | |
| 298 return ratio_cmp (XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
| 299 #endif | |
| 1995 | 300 #ifdef HAVE_BIGFLOAT |
| 301 case BIGFLOAT_T: | |
| 302 return bigfloat_cmp (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)); | |
| 303 #endif | |
| 304 default: /* FLOAT_T */ | |
| 1983 | 305 { |
| 306 double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2); | |
| 307 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; | |
| 308 } | |
| 309 } | |
| 310 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 311 retry: |
| 312 | |
| 313 { | |
| 314 EMACS_INT ival1, ival2; | |
| 315 | |
| 316 if (INTP (obj1)) ival1 = XINT (obj1); | |
| 317 else if (CHARP (obj1)) ival1 = XCHAR (obj1); | |
| 318 else if (MARKERP (obj1)) ival1 = marker_position (obj1); | |
| 319 else goto arithcompare_float; | |
| 320 | |
| 321 if (INTP (obj2)) ival2 = XINT (obj2); | |
| 322 else if (CHARP (obj2)) ival2 = XCHAR (obj2); | |
| 323 else if (MARKERP (obj2)) ival2 = marker_position (obj2); | |
| 324 else goto arithcompare_float; | |
| 325 | |
| 326 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0; | |
| 327 } | |
| 328 | |
| 329 arithcompare_float: | |
| 330 | |
| 331 { | |
| 332 double dval1, dval2; | |
| 333 | |
| 334 if (FLOATP (obj1)) dval1 = XFLOAT_DATA (obj1); | |
| 335 else if (INTP (obj1)) dval1 = (double) XINT (obj1); | |
| 336 else if (CHARP (obj1)) dval1 = (double) XCHAR (obj1); | |
| 337 else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1); | |
| 338 else | |
| 339 { | |
| 340 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); | |
| 341 goto retry; | |
| 342 } | |
| 343 | |
| 344 if (FLOATP (obj2)) dval2 = XFLOAT_DATA (obj2); | |
| 345 else if (INTP (obj2)) dval2 = (double) XINT (obj2); | |
| 346 else if (CHARP (obj2)) dval2 = (double) XCHAR (obj2); | |
| 347 else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2); | |
| 348 else | |
| 349 { | |
| 350 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); | |
| 351 goto retry; | |
| 352 } | |
| 353 | |
| 354 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; | |
| 355 } | |
| 1983 | 356 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 357 } |
| 358 | |
| 359 static Lisp_Object | |
| 360 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode) | |
| 361 { | |
| 1983 | 362 #ifdef WITH_NUMBER_TYPES |
| 363 switch (promote_args (&obj1, &obj2)) | |
| 364 { | |
| 365 case FIXNUM_T: | |
| 366 { | |
| 367 EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2); | |
| 368 switch (opcode) | |
| 369 { | |
| 370 case Bplus: ival1 += ival2; break; | |
| 371 case Bdiff: ival1 -= ival2; break; | |
| 372 case Bmult: | |
| 373 #ifdef HAVE_BIGNUM | |
| 374 /* Due to potential overflow, we compute using bignums */ | |
| 375 bignum_set_long (scratch_bignum, ival1); | |
| 376 bignum_set_long (scratch_bignum2, ival2); | |
| 377 bignum_mul (scratch_bignum, scratch_bignum, scratch_bignum2); | |
| 378 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 379 #else | |
| 380 ival1 *= ival2; break; | |
| 381 #endif | |
| 382 case Bquo: | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
383 if (ival2 == 0) |
|
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
384 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1983 | 385 ival1 /= ival2; |
| 386 break; | |
| 387 case Bmax: if (ival1 < ival2) ival1 = ival2; break; | |
| 388 case Bmin: if (ival1 > ival2) ival1 = ival2; break; | |
| 389 } | |
| 390 return make_integer (ival1); | |
| 391 } | |
| 392 #ifdef HAVE_BIGNUM | |
| 393 case BIGNUM_T: | |
| 394 switch (opcode) | |
| 395 { | |
| 396 case Bplus: | |
| 397 bignum_add (scratch_bignum, XBIGNUM_DATA (obj1), | |
| 398 XBIGNUM_DATA (obj2)); | |
| 399 break; | |
| 400 case Bdiff: | |
| 401 bignum_sub (scratch_bignum, XBIGNUM_DATA (obj1), | |
| 402 XBIGNUM_DATA (obj2)); | |
| 403 break; | |
| 404 case Bmult: | |
| 405 bignum_mul (scratch_bignum, XBIGNUM_DATA (obj1), | |
| 406 XBIGNUM_DATA (obj2)); | |
| 407 break; | |
| 408 case Bquo: | |
| 409 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
|
410 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1983 | 411 bignum_div (scratch_bignum, XBIGNUM_DATA (obj1), |
| 412 XBIGNUM_DATA (obj2)); | |
| 413 break; | |
| 414 case Bmax: | |
| 415 return bignum_gt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)) | |
| 416 ? obj1 : obj2; | |
| 417 case Bmin: | |
| 418 return bignum_lt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)) | |
| 419 ? obj1 : obj2; | |
| 420 } | |
| 421 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 422 #endif | |
| 423 #ifdef HAVE_RATIO | |
| 424 case RATIO_T: | |
| 425 switch (opcode) | |
| 426 { | |
| 427 case Bplus: | |
| 428 ratio_add (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
| 429 break; | |
| 430 case Bdiff: | |
| 431 ratio_sub (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
| 432 break; | |
| 433 case Bmult: | |
| 434 ratio_mul (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
| 435 break; | |
| 436 case Bquo: | |
| 437 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
|
438 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1983 | 439 ratio_div (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); |
| 440 break; | |
| 441 case Bmax: | |
| 442 return ratio_gt (XRATIO_DATA (obj1), XRATIO_DATA (obj2)) | |
| 443 ? obj1 : obj2; | |
| 444 case Bmin: | |
| 445 return ratio_lt (XRATIO_DATA (obj1), XRATIO_DATA (obj2)) | |
| 446 ? obj1 : obj2; | |
| 447 } | |
| 448 return make_ratio_rt (scratch_ratio); | |
| 449 #endif | |
| 450 #ifdef HAVE_BIGFLOAT | |
| 451 case BIGFLOAT_T: | |
| 452 bigfloat_set_prec (scratch_bigfloat, max (XBIGFLOAT_GET_PREC (obj1), | |
| 453 XBIGFLOAT_GET_PREC (obj2))); | |
| 454 switch (opcode) | |
| 455 { | |
| 456 case Bplus: | |
| 457 bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (obj1), | |
| 458 XBIGFLOAT_DATA (obj2)); | |
| 459 break; | |
| 460 case Bdiff: | |
| 461 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (obj1), | |
| 462 XBIGFLOAT_DATA (obj2)); | |
| 463 break; | |
| 464 case Bmult: | |
| 465 bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (obj1), | |
| 466 XBIGFLOAT_DATA (obj2)); | |
| 467 break; | |
| 468 case Bquo: | |
| 469 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
|
470 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1983 | 471 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (obj1), |
| 472 XBIGFLOAT_DATA (obj2)); | |
| 473 break; | |
| 474 case Bmax: | |
| 475 return bigfloat_gt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)) | |
| 476 ? obj1 : obj2; | |
| 477 case Bmin: | |
| 478 return bigfloat_lt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)) | |
| 479 ? obj1 : obj2; | |
| 480 } | |
| 481 return make_bigfloat_bf (scratch_bigfloat); | |
| 482 #endif | |
| 1995 | 483 default: /* FLOAT_T */ |
| 484 { | |
| 485 double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2); | |
| 486 switch (opcode) | |
| 487 { | |
| 488 case Bplus: dval1 += dval2; break; | |
| 489 case Bdiff: dval1 -= dval2; break; | |
| 490 case Bmult: dval1 *= dval2; break; | |
| 491 case Bquo: | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
492 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
|
493 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1995 | 494 dval1 /= dval2; |
| 495 break; | |
| 496 case Bmax: if (dval1 < dval2) dval1 = dval2; break; | |
| 497 case Bmin: if (dval1 > dval2) dval1 = dval2; break; | |
| 498 } | |
| 499 return make_float (dval1); | |
| 500 } | |
| 1983 | 501 } |
| 502 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 503 EMACS_INT ival1, ival2; |
| 504 int float_p; | |
| 505 | |
| 506 retry: | |
| 507 | |
| 508 float_p = 0; | |
| 509 | |
| 510 if (INTP (obj1)) ival1 = XINT (obj1); | |
| 511 else if (CHARP (obj1)) ival1 = XCHAR (obj1); | |
| 512 else if (MARKERP (obj1)) ival1 = marker_position (obj1); | |
| 513 else if (FLOATP (obj1)) ival1 = 0, float_p = 1; | |
| 514 else | |
| 515 { | |
| 516 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); | |
| 517 goto retry; | |
| 518 } | |
| 519 | |
| 520 if (INTP (obj2)) ival2 = XINT (obj2); | |
| 521 else if (CHARP (obj2)) ival2 = XCHAR (obj2); | |
| 522 else if (MARKERP (obj2)) ival2 = marker_position (obj2); | |
| 523 else if (FLOATP (obj2)) ival2 = 0, float_p = 1; | |
| 524 else | |
| 525 { | |
| 526 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); | |
| 527 goto retry; | |
| 528 } | |
| 529 | |
| 530 if (!float_p) | |
| 531 { | |
| 532 switch (opcode) | |
| 533 { | |
| 534 case Bplus: ival1 += ival2; break; | |
| 535 case Bdiff: ival1 -= ival2; break; | |
| 536 case Bmult: ival1 *= ival2; break; | |
| 537 case Bquo: | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
538 if (ival2 == 0) |
|
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
539 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 428 | 540 ival1 /= ival2; |
| 541 break; | |
| 542 case Bmax: if (ival1 < ival2) ival1 = ival2; break; | |
| 543 case Bmin: if (ival1 > ival2) ival1 = ival2; break; | |
| 544 } | |
| 545 return make_int (ival1); | |
| 546 } | |
| 547 else | |
| 548 { | |
| 549 double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1; | |
| 550 double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2; | |
| 551 switch (opcode) | |
| 552 { | |
| 553 case Bplus: dval1 += dval2; break; | |
| 554 case Bdiff: dval1 -= dval2; break; | |
| 555 case Bmult: dval1 *= dval2; break; | |
| 556 case Bquo: | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
557 if (dval2 == 0) |
|
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
558 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 428 | 559 dval1 /= dval2; |
| 560 break; | |
| 561 case Bmax: if (dval1 < dval2) dval1 = dval2; break; | |
| 562 case Bmin: if (dval1 > dval2) dval1 = dval2; break; | |
| 563 } | |
| 564 return make_float (dval1); | |
| 565 } | |
| 1983 | 566 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 567 } |
| 568 | |
| 569 | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
570 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
571 /*********************** The instruction array *********************/ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
572 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
573 /* Check that there are at least LEN elements left in the end of the |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
574 instruction array before fetching them. Note that we allow for |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
575 PROGRAM_PTR == PROGRAM_END after the fetch -- that means there are |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
576 no more elements to fetch next time around, but we might exit before |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
577 next time comes. |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
578 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
579 When checking the destination if jumps, however, we don't allow |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
580 PROGRAM_PTR to equal PROGRAM_END, since we will always be fetching |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
581 another instruction after the jump. */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
582 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
583 #define CHECK_OPCODE_SPACE(len) \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
584 bytecode_assert (program_ptr + len <= program_end) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
585 |
| 428 | 586 /* Read next uint8 from the instruction stream. */ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
587 #define READ_UINT_1 \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
588 (CHECK_OPCODE_SPACE (1), (unsigned int) (unsigned char) *program_ptr++) |
| 428 | 589 |
| 590 /* Read next uint16 from the instruction stream. */ | |
| 591 #define READ_UINT_2 \ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
592 (CHECK_OPCODE_SPACE (2), \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
593 program_ptr += 2, \ |
| 428 | 594 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \ |
| 595 ((unsigned int) (unsigned char) program_ptr[-2]))) | |
| 596 | |
| 597 /* Read next int8 from the instruction stream. */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
598 #define READ_INT_1 \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
599 (CHECK_OPCODE_SPACE (1), (int) (signed char) *program_ptr++) |
| 428 | 600 |
| 601 /* Read next int16 from the instruction stream. */ | |
| 602 #define READ_INT_2 \ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
603 (CHECK_OPCODE_SPACE (2), \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
604 program_ptr += 2, \ |
| 428 | 605 (((int) ( signed char) program_ptr[-1]) * 256 + \ |
| 606 ((int) (unsigned char) program_ptr[-2]))) | |
| 607 | |
| 608 /* Read next int8 from instruction stream; don't advance program_pointer */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
609 #define PEEK_INT_1 \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
610 (CHECK_OPCODE_SPACE (1), (int) (signed char) program_ptr[0]) |
| 428 | 611 |
| 612 /* Read next int16 from instruction stream; don't advance program_pointer */ | |
| 613 #define PEEK_INT_2 \ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
614 (CHECK_OPCODE_SPACE (2), \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
615 (((int) ( signed char) program_ptr[1]) * 256) | \ |
| 428 | 616 ((int) (unsigned char) program_ptr[0])) |
| 617 | |
| 618 /* Do relative jumps from the current location. | |
| 619 We only do a QUIT if we jump backwards, for efficiency. | |
| 620 No infloops without backward jumps! */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
621 #define JUMP_RELATIVE(jump) do { \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
622 int _JR_jump = (jump); \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
623 if (_JR_jump < 0) QUIT; \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
624 /* Check that where we're going to is in range. Note that we don't use \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
625 CHECK_OPCODE_SPACE() -- that only checks the end, and it allows \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
626 program_ptr == program_end, which we don't allow. */ \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
627 bytecode_assert (program_ptr + _JR_jump >= program && \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
628 program_ptr + _JR_jump < program_end); \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
629 program_ptr += _JR_jump; \ |
| 428 | 630 } while (0) |
| 631 | |
| 632 #define JUMP JUMP_RELATIVE (PEEK_INT_2) | |
| 633 #define JUMPR JUMP_RELATIVE (PEEK_INT_1) | |
| 634 | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
635 #define JUMP_NEXT (CHECK_OPCODE_SPACE (2), (void) (program_ptr += 2)) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
636 #define JUMPR_NEXT (CHECK_OPCODE_SPACE (1), (void) (program_ptr += 1)) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
637 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
638 /*********************** The stack array *********************/ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
639 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
640 /* NOTE: The stack array doesn't work quite like you'd expect. |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
641 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
642 STACK_PTR points to the value on the top of the stack. Popping a value |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
643 fetches the value from the STACK_PTR and then decrements it. Pushing a |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
644 value first increments it, then writes the new value. STACK_PTR - |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
645 STACK_BEG is the number of elements on the stack. |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
646 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
647 This means that when STACK_PTR == STACK_BEG, the stack is empty, and |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
648 the space at STACK_BEG is never written to -- the first push will write |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
649 into the space directly after STACK_BEG. This is why the call to |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
650 alloca_array() below has a count of `stack_depth + 1', and why |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
651 we GCPRO1 (stack_ptr[1]) -- the value at stack_ptr[0] is unused and |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
652 uninitialized. |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
653 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
654 Also, STACK_END actually points to the last usable storage location, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
655 and does not point past the end, like you'd expect. */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
656 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
657 #define CHECK_STACKPTR_OFFSET(len) \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
658 bytecode_assert (stack_ptr + (len) >= stack_beg && \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
659 stack_ptr + (len) <= stack_end) |
| 428 | 660 |
| 661 /* Push x onto the execution stack. */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
662 #define PUSH(x) (CHECK_STACKPTR_OFFSET (1), *++stack_ptr = (x)) |
| 428 | 663 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
664 /* Pop a value, which may be multiple, off the execution stack. */ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
665 #define POP_WITH_MULTIPLE_VALUES (CHECK_STACKPTR_OFFSET (-1), *stack_ptr--) |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
666 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
667 /* 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
|
668 #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
|
669 |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
670 /* ..._UNSAFE() means it evaluates its argument more than once. */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
671 #define DISCARD_PRESERVING_MULTIPLE_VALUES_UNSAFE(n) \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
672 (CHECK_STACKPTR_OFFSET (-(n)), stack_ptr -= (n)) |
| 428 | 673 |
| 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 { \ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
676 int _discard_n = (n); \ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
677 if (1 != multiple_value_current_limit) \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
678 { \ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
679 int i; \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
680 for (i = 0; i < _discard_n; i++) \ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
681 { \ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
682 CHECK_STACKPTR_OFFSET (-1); \ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
683 *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
|
684 stack_ptr--; \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
685 } \ |
|
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 else \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
688 { \ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
689 CHECK_STACKPTR_OFFSET (-_discard_n); \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
690 stack_ptr -= _discard_n; \ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
691 } \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
692 } while (0) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
693 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
694 /* 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
|
695 and leave it there. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
696 #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
|
697 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
698 #define TOP_ADDRESS (stack_ptr) |
| 428 | 699 |
| 700 /* Get the value which is at the top of the execution stack, | |
| 701 but don't pop it. */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
702 #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
|
703 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
704 #define TOP_LVALUE (*stack_ptr) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
705 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
706 |
| 428 | 707 |
| 1920 | 708 /* See comment before the big switch in execute_optimized_program(). */ |
| 1884 | 709 #define GCPRO_STACK (gcpro1.nvars = stack_ptr - stack_beg) |
| 710 | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
711 |
| 428 | 712 /* The actual interpreter for byte code. |
| 713 This function has been seriously optimized for performance. | |
| 714 Don't change the constructs unless you are willing to do | |
| 715 real benchmarking and profiling work -- martin */ | |
| 716 | |
| 717 | |
| 814 | 718 Lisp_Object |
| 442 | 719 execute_optimized_program (const Opbyte *program, |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
720 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
721 Elemcount program_length, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
722 #endif |
| 428 | 723 int stack_depth, |
| 724 Lisp_Object *constants_data) | |
| 725 { | |
| 726 /* This function can GC */ | |
| 442 | 727 REGISTER const Opbyte *program_ptr = (Opbyte *) program; |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
728 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
729 const Opbyte *program_end = program_ptr + program_length; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
730 #endif |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
731 /* See comment above explaining the `+ 1' */ |
| 1884 | 732 Lisp_Object *stack_beg = alloca_array (Lisp_Object, stack_depth + 1); |
| 733 REGISTER Lisp_Object *stack_ptr = stack_beg; | |
| 428 | 734 int speccount = specpdl_depth (); |
| 735 struct gcpro gcpro1; | |
| 736 | |
| 737 #ifdef BYTE_CODE_METER | |
| 4925 | 738 Opcode this_opcode = (Opcode) 0; |
| 428 | 739 Opcode prev_opcode; |
| 740 #endif | |
| 741 | |
| 742 #ifdef ERROR_CHECK_BYTE_CODE | |
| 743 Lisp_Object *stack_end = stack_beg + stack_depth; | |
| 744 #endif | |
| 745 | |
| 1920 | 746 /* We used to GCPRO the whole interpreter stack before entering this while |
| 747 loop (21.5.14 and before), but that interferes with collection of weakly | |
| 748 referenced objects. Although strictly speaking there's no promise that | |
| 749 weak references will disappear by any given point in time, they should | |
| 750 be collected at the first opportunity. Waiting until exit from the | |
| 751 function caused test failures because "stale" objects "above" the top of | |
| 752 the stack were still GCPROed, and they were not getting collected until | |
| 753 after exit from the (byte-compiled) test! | |
| 754 | |
| 755 Now the idea is to dynamically adjust the array of GCPROed objects to | |
| 756 include only the "active" region of the stack. | |
| 757 | |
| 758 We use the "GCPRO1 the array base and set the nvars member" method. It | |
| 759 would be slightly inefficient but correct to use GCPRO1_ARRAY here. It | |
| 760 would just redundantly set nvars. | |
| 761 #### Maybe it would be clearer to use GCPRO1_ARRAY and do GCPRO_STACK | |
| 762 after the switch? | |
| 763 | |
| 764 GCPRO_STACK is something of a misnomer, because it suggests that a | |
| 765 struct gcpro is initialized each time. This is false; only the nvars | |
| 766 member of a single struct gcpro is being adjusted. This works because | |
| 767 each time a new object is assigned to a stack location, the old object | |
| 768 loses its reference and is effectively UNGCPROed, and the new object is | |
| 769 automatically GCPROed as long as nvars is correct. Only when we | |
| 770 return from the interpreter do we need to finalize the struct gcpro | |
| 771 itself, and that's done at case Breturn. | |
| 772 */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
773 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
774 /* See comment above explaining the `[1]' */ |
| 428 | 775 GCPRO1 (stack_ptr[1]); |
| 1758 | 776 |
| 428 | 777 while (1) |
| 778 { | |
| 779 REGISTER Opcode opcode = (Opcode) READ_UINT_1; | |
| 1920 | 780 |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
781 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
782 remember_operation (opcode); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
783 #endif |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
784 |
| 1920 | 785 GCPRO_STACK; /* Get nvars right before maybe signaling. */ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
786 /* #### NOTE: This code should probably never get triggered, since we |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
787 now catch the problems earlier, farther down, before we ever set |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
788 a bad value for STACK_PTR. */ |
| 428 | 789 #ifdef ERROR_CHECK_BYTE_CODE |
| 790 if (stack_ptr > stack_end) | |
| 563 | 791 stack_overflow ("byte code stack overflow", Qunbound); |
| 428 | 792 if (stack_ptr < stack_beg) |
| 563 | 793 stack_overflow ("byte code stack underflow", Qunbound); |
| 428 | 794 #endif |
| 795 | |
| 796 #ifdef BYTE_CODE_METER | |
| 797 prev_opcode = this_opcode; | |
| 798 this_opcode = opcode; | |
| 799 meter_code (prev_opcode, this_opcode); | |
| 800 #endif | |
| 801 | |
| 802 switch (opcode) | |
| 803 { | |
| 804 REGISTER int n; | |
| 805 | |
| 806 default: | |
| 807 if (opcode >= Bconstant) | |
| 808 PUSH (constants_data[opcode - Bconstant]); | |
| 809 else | |
| 1884 | 810 { |
| 811 /* We're not sure what these do, so better safe than sorry. */ | |
| 812 /* GCPRO_STACK; */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
813 stack_ptr = execute_rare_opcode (stack_ptr, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
814 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
815 stack_beg, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
816 stack_end, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
817 #endif /* ERROR_CHECK_BYTE_CODE */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
818 program_ptr, opcode); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
819 CHECK_STACKPTR_OFFSET (0); |
| 1884 | 820 } |
| 428 | 821 break; |
| 822 | |
| 823 case Bvarref: | |
| 824 case Bvarref+1: | |
| 825 case Bvarref+2: | |
| 826 case Bvarref+3: | |
| 827 case Bvarref+4: | |
| 828 case Bvarref+5: n = opcode - Bvarref; goto do_varref; | |
| 829 case Bvarref+7: n = READ_UINT_2; goto do_varref; | |
| 830 case Bvarref+6: n = READ_UINT_1; /* most common */ | |
| 831 do_varref: | |
| 832 { | |
| 833 Lisp_Object symbol = constants_data[n]; | |
| 834 Lisp_Object value = XSYMBOL (symbol)->value; | |
| 835 if (SYMBOL_VALUE_MAGIC_P (value)) | |
| 1920 | 836 /* I GCPRO_STACKed Fsymbol_value elsewhere, but I dunno why. */ |
| 837 /* GCPRO_STACK; */ | |
| 428 | 838 value = Fsymbol_value (symbol); |
| 839 PUSH (value); | |
| 840 break; | |
| 841 } | |
| 842 | |
| 843 case Bvarset: | |
| 844 case Bvarset+1: | |
| 845 case Bvarset+2: | |
| 846 case Bvarset+3: | |
| 847 case Bvarset+4: | |
| 848 case Bvarset+5: n = opcode - Bvarset; goto do_varset; | |
| 849 case Bvarset+7: n = READ_UINT_2; goto do_varset; | |
| 850 case Bvarset+6: n = READ_UINT_1; /* most common */ | |
| 851 do_varset: | |
| 852 { | |
| 853 Lisp_Object symbol = constants_data[n]; | |
| 440 | 854 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); |
| 428 | 855 Lisp_Object old_value = symbol_ptr->value; |
| 856 Lisp_Object new_value = POP; | |
| 1661 | 857 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) |
| 428 | 858 symbol_ptr->value = new_value; |
| 1884 | 859 else { |
| 860 /* Fset may call magic handlers */ | |
| 861 /* GCPRO_STACK; */ | |
| 428 | 862 Fset (symbol, new_value); |
| 1884 | 863 } |
| 864 | |
| 428 | 865 break; |
| 866 } | |
| 867 | |
| 868 case Bvarbind: | |
| 869 case Bvarbind+1: | |
| 870 case Bvarbind+2: | |
| 871 case Bvarbind+3: | |
| 872 case Bvarbind+4: | |
| 873 case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind; | |
| 874 case Bvarbind+7: n = READ_UINT_2; goto do_varbind; | |
| 875 case Bvarbind+6: n = READ_UINT_1; /* most common */ | |
| 876 do_varbind: | |
| 877 { | |
| 878 Lisp_Object symbol = constants_data[n]; | |
| 440 | 879 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); |
| 428 | 880 Lisp_Object old_value = symbol_ptr->value; |
| 881 Lisp_Object new_value = POP; | |
| 882 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) | |
| 883 { | |
| 884 specpdl_ptr->symbol = symbol; | |
| 885 specpdl_ptr->old_value = old_value; | |
| 886 specpdl_ptr->func = 0; | |
| 887 specpdl_ptr++; | |
| 888 specpdl_depth_counter++; | |
| 889 | |
| 890 symbol_ptr->value = new_value; | |
| 853 | 891 |
| 892 #ifdef ERROR_CHECK_CATCH | |
| 893 check_specbind_stack_sanity (); | |
| 894 #endif | |
| 428 | 895 } |
| 896 else | |
| 1884 | 897 { |
| 898 /* does an Fset, may call magic handlers */ | |
| 899 /* GCPRO_STACK; */ | |
| 900 specbind_magic (symbol, new_value); | |
| 901 } | |
| 428 | 902 break; |
| 903 } | |
| 904 | |
| 905 case Bcall: | |
| 906 case Bcall+1: | |
| 907 case Bcall+2: | |
| 908 case Bcall+3: | |
| 909 case Bcall+4: | |
| 910 case Bcall+5: | |
| 911 case Bcall+6: | |
| 912 case Bcall+7: | |
| 913 n = (opcode < Bcall+6 ? opcode - Bcall : | |
| 914 opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2); | |
| 1920 | 915 /* #### Shouldn't this be just before the Ffuncall? |
| 916 Neither Fget nor Fput can GC. */ | |
| 1884 | 917 /* GCPRO_STACK; */ |
| 428 | 918 DISCARD (n); |
| 919 #ifdef BYTE_CODE_METER | |
| 920 if (byte_metering_on && SYMBOLP (TOP)) | |
| 921 { | |
| 922 Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil); | |
| 923 if (INTP (val)) | |
| 924 Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1)); | |
| 925 } | |
| 926 #endif | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
927 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
928 TOP_LVALUE = Ffuncall (n + 1, TOP_ADDRESS); |
| 428 | 929 break; |
| 930 | |
| 931 case Bunbind: | |
| 932 case Bunbind+1: | |
| 933 case Bunbind+2: | |
| 934 case Bunbind+3: | |
| 935 case Bunbind+4: | |
| 936 case Bunbind+5: | |
| 937 case Bunbind+6: | |
| 938 case Bunbind+7: | |
| 939 UNBIND_TO (specpdl_depth() - | |
| 940 (opcode < Bunbind+6 ? opcode-Bunbind : | |
| 941 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2)); | |
| 942 break; | |
| 943 | |
| 944 | |
| 945 case Bgoto: | |
| 946 JUMP; | |
| 947 break; | |
| 948 | |
| 949 case Bgotoifnil: | |
| 950 if (NILP (POP)) | |
| 951 JUMP; | |
| 952 else | |
| 953 JUMP_NEXT; | |
| 954 break; | |
| 955 | |
| 956 case Bgotoifnonnil: | |
| 957 if (!NILP (POP)) | |
| 958 JUMP; | |
| 959 else | |
| 960 JUMP_NEXT; | |
| 961 break; | |
| 962 | |
| 963 case Bgotoifnilelsepop: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
964 /* Discard any multiple value: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
965 if (NILP (TOP_LVALUE = TOP)) |
| 428 | 966 JUMP; |
| 967 else | |
| 968 { | |
| 969 DISCARD (1); | |
| 970 JUMP_NEXT; | |
| 971 } | |
| 972 break; | |
| 973 | |
| 974 case Bgotoifnonnilelsepop: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
975 /* Discard any multiple value: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
976 if (!NILP (TOP_LVALUE = TOP)) |
| 428 | 977 JUMP; |
| 978 else | |
| 979 { | |
| 980 DISCARD (1); | |
| 981 JUMP_NEXT; | |
| 982 } | |
| 983 break; | |
| 984 | |
| 985 | |
| 986 case BRgoto: | |
| 987 JUMPR; | |
| 988 break; | |
| 989 | |
| 990 case BRgotoifnil: | |
| 991 if (NILP (POP)) | |
| 992 JUMPR; | |
| 993 else | |
| 994 JUMPR_NEXT; | |
| 995 break; | |
| 996 | |
| 997 case BRgotoifnonnil: | |
| 998 if (!NILP (POP)) | |
| 999 JUMPR; | |
| 1000 else | |
| 1001 JUMPR_NEXT; | |
| 1002 break; | |
| 1003 | |
| 1004 case BRgotoifnilelsepop: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1005 if (NILP (TOP_LVALUE = TOP)) |
| 428 | 1006 JUMPR; |
| 1007 else | |
| 1008 { | |
| 1009 DISCARD (1); | |
| 1010 JUMPR_NEXT; | |
| 1011 } | |
| 1012 break; | |
| 1013 | |
| 1014 case BRgotoifnonnilelsepop: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1015 if (!NILP (TOP_LVALUE = TOP)) |
| 428 | 1016 JUMPR; |
| 1017 else | |
| 1018 { | |
| 1019 DISCARD (1); | |
| 1020 JUMPR_NEXT; | |
| 1021 } | |
| 1022 break; | |
| 1023 | |
| 1024 case Breturn: | |
| 1025 UNGCPRO; | |
| 1026 #ifdef ERROR_CHECK_BYTE_CODE | |
| 1027 /* Binds and unbinds are supposed to be compiled balanced. */ | |
| 1028 if (specpdl_depth() != speccount) | |
| 563 | 1029 invalid_byte_code ("unbalanced specbinding stack", Qunbound); |
| 428 | 1030 #endif |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1031 return TOP_WITH_MULTIPLE_VALUES; |
| 428 | 1032 |
| 1033 case Bdiscard: | |
| 1034 DISCARD (1); | |
| 1035 break; | |
| 1036 | |
| 1037 case Bdup: | |
| 1038 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1039 Lisp_Object arg = TOP_WITH_MULTIPLE_VALUES; |
| 428 | 1040 PUSH (arg); |
| 1041 break; | |
| 1042 } | |
| 1043 | |
| 1044 case Bconstant2: | |
| 1045 PUSH (constants_data[READ_UINT_2]); | |
| 1046 break; | |
| 1047 | |
| 1048 case Bcar: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1049 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1050 /* 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
|
1051 /* GCPRO_STACK; */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1052 Lisp_Object arg = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1053 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
|
1054 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1055 } |
| 428 | 1056 |
| 1057 case Bcdr: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1058 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1059 /* 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
|
1060 /* GCPRO_STACK; */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1061 Lisp_Object arg = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1062 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
|
1063 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1064 } |
| 428 | 1065 |
| 1066 case Bunbind_all: | |
| 1067 /* To unbind back to the beginning of this frame. Not used yet, | |
| 1068 but will be needed for tail-recursion elimination. */ | |
| 771 | 1069 unbind_to (speccount); |
| 428 | 1070 break; |
| 1071 | |
| 1072 case Bnth: | |
| 1073 { | |
| 1074 Lisp_Object arg = POP; | |
| 1920 | 1075 /* Fcar and Fnthcdr can GC via wrong_type_argument. */ |
| 1076 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1077 TOP_LVALUE = Fcar (Fnthcdr (TOP, arg)); |
| 428 | 1078 break; |
| 1079 } | |
| 1080 | |
| 1081 case Bsymbolp: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1082 TOP_LVALUE = SYMBOLP (TOP) ? Qt : Qnil; |
| 428 | 1083 break; |
| 1084 | |
| 1085 case Bconsp: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1086 TOP_LVALUE = CONSP (TOP) ? Qt : Qnil; |
| 428 | 1087 break; |
| 1088 | |
| 1089 case Bstringp: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1090 TOP_LVALUE = STRINGP (TOP) ? Qt : Qnil; |
| 428 | 1091 break; |
| 1092 | |
| 1093 case Blistp: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1094 TOP_LVALUE = LISTP (TOP) ? Qt : Qnil; |
| 428 | 1095 break; |
| 1096 | |
| 1097 case Bnumberp: | |
| 1983 | 1098 #ifdef WITH_NUMBER_TYPES |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1099 TOP_LVALUE = NUMBERP (TOP) ? Qt : Qnil; |
| 1983 | 1100 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1101 TOP_LVALUE = INT_OR_FLOATP (TOP) ? Qt : Qnil; |
| 1983 | 1102 #endif |
| 428 | 1103 break; |
| 1104 | |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4775
diff
changeset
|
1105 case Bfixnump: |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1106 TOP_LVALUE = INTP (TOP) ? Qt : Qnil; |
| 428 | 1107 break; |
| 1108 | |
| 1109 case Beq: | |
| 1110 { | |
| 1111 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1112 TOP_LVALUE = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil; |
| 428 | 1113 break; |
| 1114 } | |
| 1115 | |
| 1116 case Bnot: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1117 TOP_LVALUE = NILP (TOP) ? Qt : Qnil; |
| 428 | 1118 break; |
| 1119 | |
| 1120 case Bcons: | |
| 1121 { | |
| 1122 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1123 TOP_LVALUE = Fcons (TOP, arg); |
| 428 | 1124 break; |
| 1125 } | |
| 1126 | |
| 1127 case Blist1: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1128 TOP_LVALUE = Fcons (TOP, Qnil); |
| 428 | 1129 break; |
| 1130 | |
| 1131 | |
| 1132 case BlistN: | |
| 1133 n = READ_UINT_1; | |
| 1134 goto do_list; | |
| 1135 | |
| 1136 case Blist2: | |
| 1137 case Blist3: | |
| 1138 case Blist4: | |
| 1139 /* common case */ | |
| 1140 n = opcode - (Blist1 - 1); | |
| 1141 do_list: | |
| 1142 { | |
| 1143 Lisp_Object list = Qnil; | |
| 1144 list_loop: | |
| 1145 list = Fcons (TOP, list); | |
| 1146 if (--n) | |
| 1147 { | |
| 1148 DISCARD (1); | |
| 1149 goto list_loop; | |
| 1150 } | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1151 TOP_LVALUE = list; |
| 428 | 1152 break; |
| 1153 } | |
| 1154 | |
| 1155 | |
| 1156 case Bconcat2: | |
| 1157 case Bconcat3: | |
| 1158 case Bconcat4: | |
| 1159 n = opcode - (Bconcat2 - 2); | |
| 1160 goto do_concat; | |
| 1161 | |
| 1162 case BconcatN: | |
| 1163 /* common case */ | |
| 1164 n = READ_UINT_1; | |
| 1165 do_concat: | |
| 1166 DISCARD (n - 1); | |
| 1920 | 1167 /* Apparently `concat' can GC; Fconcat GCPROs its arguments. */ |
| 1168 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1169 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1170 TOP_LVALUE = Fconcat (n, TOP_ADDRESS); |
| 428 | 1171 break; |
| 1172 | |
| 1173 | |
| 1174 case Blength: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1175 TOP_LVALUE = Flength (TOP); |
| 428 | 1176 break; |
| 1177 | |
| 1178 case Baset: | |
| 1179 { | |
| 1180 Lisp_Object arg2 = POP; | |
| 1181 Lisp_Object arg1 = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1182 TOP_LVALUE = Faset (TOP, arg1, arg2); |
| 428 | 1183 break; |
| 1184 } | |
| 1185 | |
| 1186 case Bsymbol_value: | |
| 1920 | 1187 /* Why does this need GCPRO_STACK? If not, remove others, too. */ |
| 1884 | 1188 /* GCPRO_STACK; */ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1189 TOP_LVALUE = Fsymbol_value (TOP); |
| 428 | 1190 break; |
| 1191 | |
| 1192 case Bsymbol_function: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1193 TOP_LVALUE = Fsymbol_function (TOP); |
| 428 | 1194 break; |
| 1195 | |
| 1196 case Bget: | |
| 1197 { | |
| 1198 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1199 TOP_LVALUE = Fget (TOP, arg, Qnil); |
| 428 | 1200 break; |
| 1201 } | |
| 1202 | |
| 1203 case Bsub1: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1204 { |
| 1983 | 1205 #ifdef HAVE_BIGNUM |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1206 TOP_LVALUE = Fsub1 (TOP); |
| 1983 | 1207 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1208 Lisp_Object arg = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1209 TOP_LVALUE = INTP (arg) ? INT_MINUS1 (arg) : Fsub1 (arg); |
| 1983 | 1210 #endif |
| 428 | 1211 break; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1212 } |
| 428 | 1213 case Badd1: |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1214 { |
| 1983 | 1215 #ifdef HAVE_BIGNUM |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1216 TOP_LVALUE = Fadd1 (TOP); |
| 1983 | 1217 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1218 Lisp_Object arg = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1219 TOP_LVALUE = INTP (arg) ? INT_PLUS1 (arg) : Fadd1 (arg); |
| 1983 | 1220 #endif |
| 428 | 1221 break; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1222 } |
| 428 | 1223 |
| 1224 case Beqlsign: | |
| 1225 { | |
| 1226 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1227 TOP_LVALUE = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil; |
| 428 | 1228 break; |
| 1229 } | |
| 1230 | |
| 1231 case Bgtr: | |
| 1232 { | |
| 1233 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1234 TOP_LVALUE = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil; |
| 428 | 1235 break; |
| 1236 } | |
| 1237 | |
| 1238 case Blss: | |
| 1239 { | |
| 1240 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1241 TOP_LVALUE = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil; |
| 428 | 1242 break; |
| 1243 } | |
| 1244 | |
| 1245 case Bleq: | |
| 1246 { | |
| 1247 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1248 TOP_LVALUE = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil; |
| 428 | 1249 break; |
| 1250 } | |
| 1251 | |
| 1252 case Bgeq: | |
| 1253 { | |
| 1254 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1255 TOP_LVALUE = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil; |
| 428 | 1256 break; |
| 1257 } | |
| 1258 | |
| 1259 | |
| 1260 case Bnegate: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1261 TOP_LVALUE = bytecode_negate (TOP); |
| 428 | 1262 break; |
| 1263 | |
| 1264 case Bnconc: | |
| 1265 DISCARD (1); | |
| 1920 | 1266 /* nconc2 GCPROs before calling this. */ |
| 1267 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1268 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1269 TOP_LVALUE = bytecode_nconc2 (TOP_ADDRESS); |
| 428 | 1270 break; |
| 1271 | |
| 1272 case Bplus: | |
| 1273 { | |
| 1274 Lisp_Object arg2 = POP; | |
| 1275 Lisp_Object arg1 = TOP; | |
| 1983 | 1276 #ifdef HAVE_BIGNUM |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1277 TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode); |
| 1983 | 1278 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1279 TOP_LVALUE = INTP (arg1) && INTP (arg2) ? |
| 428 | 1280 INT_PLUS (arg1, arg2) : |
| 1281 bytecode_arithop (arg1, arg2, opcode); | |
| 1983 | 1282 #endif |
| 428 | 1283 break; |
| 1284 } | |
| 1285 | |
| 1286 case Bdiff: | |
| 1287 { | |
| 1288 Lisp_Object arg2 = POP; | |
| 1289 Lisp_Object arg1 = TOP; | |
| 1983 | 1290 #ifdef HAVE_BIGNUM |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1291 TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode); |
| 1983 | 1292 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1293 TOP_LVALUE = INTP (arg1) && INTP (arg2) ? |
| 428 | 1294 INT_MINUS (arg1, arg2) : |
| 1295 bytecode_arithop (arg1, arg2, opcode); | |
| 1983 | 1296 #endif |
| 428 | 1297 break; |
| 1298 } | |
| 1299 | |
| 1300 case Bmult: | |
| 1301 case Bquo: | |
| 1302 case Bmax: | |
| 1303 case Bmin: | |
| 1304 { | |
| 1305 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1306 TOP_LVALUE = bytecode_arithop (TOP, arg, opcode); |
| 428 | 1307 break; |
| 1308 } | |
| 1309 | |
| 1310 case Bpoint: | |
| 1311 PUSH (make_int (BUF_PT (current_buffer))); | |
| 1312 break; | |
| 1313 | |
| 1314 case Binsert: | |
| 1920 | 1315 /* Says it can GC. */ |
| 1316 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1317 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1318 TOP_LVALUE = Finsert (1, TOP_ADDRESS); |
| 428 | 1319 break; |
| 1320 | |
| 1321 case BinsertN: | |
| 1322 n = READ_UINT_1; | |
| 1323 DISCARD (n - 1); | |
| 1920 | 1324 /* See Binsert. */ |
| 1325 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1326 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1327 TOP_LVALUE = Finsert (n, TOP_ADDRESS); |
| 428 | 1328 break; |
| 1329 | |
| 1330 case Baref: | |
| 1331 { | |
| 1332 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1333 TOP_LVALUE = Faref (TOP, arg); |
| 428 | 1334 break; |
| 1335 } | |
| 1336 | |
| 1337 case Bmemq: | |
| 1338 { | |
| 1339 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1340 TOP_LVALUE = Fmemq (TOP, arg); |
| 428 | 1341 break; |
| 1342 } | |
| 1343 | |
| 1344 case Bset: | |
| 1345 { | |
| 1346 Lisp_Object arg = POP; | |
| 1884 | 1347 /* Fset may call magic handlers */ |
| 1348 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1349 TOP_LVALUE = Fset (TOP, arg); |
| 428 | 1350 break; |
| 1351 } | |
| 1352 | |
| 1353 case Bequal: | |
| 1354 { | |
| 1355 Lisp_Object arg = POP; | |
| 1920 | 1356 /* Can QUIT, so can GC, right? */ |
| 1357 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1358 TOP_LVALUE = Fequal (TOP, arg); |
| 428 | 1359 break; |
| 1360 } | |
| 1361 | |
| 1362 case Bnthcdr: | |
| 1363 { | |
| 1364 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1365 TOP_LVALUE = Fnthcdr (TOP, arg); |
| 428 | 1366 break; |
| 1367 } | |
| 1368 | |
| 1369 case Belt: | |
| 1370 { | |
| 1371 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1372 TOP_LVALUE = Felt (TOP, arg); |
| 428 | 1373 break; |
| 1374 } | |
| 1375 | |
| 1376 case Bmember: | |
| 1377 { | |
| 1378 Lisp_Object arg = POP; | |
| 1920 | 1379 /* Can QUIT, so can GC, right? */ |
| 1380 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1381 TOP_LVALUE = Fmember (TOP, arg); |
| 428 | 1382 break; |
| 1383 } | |
| 1384 | |
| 1385 case Bgoto_char: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1386 TOP_LVALUE = Fgoto_char (TOP, Qnil); |
| 428 | 1387 break; |
| 1388 | |
| 1389 case Bcurrent_buffer: | |
| 1390 { | |
| 793 | 1391 Lisp_Object buffer = wrap_buffer (current_buffer); |
| 1392 | |
| 428 | 1393 PUSH (buffer); |
| 1394 break; | |
| 1395 } | |
| 1396 | |
| 1397 case Bset_buffer: | |
| 1884 | 1398 /* #### WAG: set-buffer may cause Fset's of buffer locals |
| 1399 Didn't prevent crash. :-( */ | |
| 1400 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1401 TOP_LVALUE = Fset_buffer (TOP); |
| 428 | 1402 break; |
| 1403 | |
| 1404 case Bpoint_max: | |
| 1405 PUSH (make_int (BUF_ZV (current_buffer))); | |
| 1406 break; | |
| 1407 | |
| 1408 case Bpoint_min: | |
| 1409 PUSH (make_int (BUF_BEGV (current_buffer))); | |
| 1410 break; | |
| 1411 | |
| 1412 case Bskip_chars_forward: | |
| 1413 { | |
| 1414 Lisp_Object arg = POP; | |
| 1920 | 1415 /* Can QUIT, so can GC, right? */ |
| 1416 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1417 TOP_LVALUE = Fskip_chars_forward (TOP, arg, Qnil); |
| 428 | 1418 break; |
| 1419 } | |
| 1420 | |
| 1421 case Bassq: | |
| 1422 { | |
| 1423 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1424 TOP_LVALUE = Fassq (TOP, arg); |
| 428 | 1425 break; |
| 1426 } | |
| 1427 | |
| 1428 case Bsetcar: | |
| 1429 { | |
| 1430 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1431 TOP_LVALUE = Fsetcar (TOP, arg); |
| 428 | 1432 break; |
| 1433 } | |
| 1434 | |
| 1435 case Bsetcdr: | |
| 1436 { | |
| 1437 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1438 TOP_LVALUE = Fsetcdr (TOP, arg); |
| 428 | 1439 break; |
| 1440 } | |
| 1441 | |
| 1442 case Bnreverse: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1443 TOP_LVALUE = bytecode_nreverse (TOP); |
| 428 | 1444 break; |
| 1445 | |
| 1446 case Bcar_safe: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1447 TOP_LVALUE = CONSP (TOP) ? XCAR (TOP) : Qnil; |
| 428 | 1448 break; |
| 1449 | |
| 1450 case Bcdr_safe: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1451 TOP_LVALUE = CONSP (TOP) ? XCDR (TOP) : Qnil; |
| 428 | 1452 break; |
| 1453 | |
| 1454 } | |
| 1455 } | |
| 1456 } | |
| 1457 | |
| 1458 /* It makes a worthwhile performance difference (5%) to shunt | |
| 1459 lesser-used opcodes off to a subroutine, to keep the switch in | |
| 1460 execute_optimized_program small. If you REALLY care about | |
| 1461 performance, you want to keep your heavily executed code away from | |
| 1462 rarely executed code, to minimize cache misses. | |
| 1463 | |
| 1464 Don't make this function static, since then the compiler might inline it. */ | |
| 1465 Lisp_Object * | |
| 1466 execute_rare_opcode (Lisp_Object *stack_ptr, | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1467 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1468 Lisp_Object *stack_beg, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1469 Lisp_Object *stack_end, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1470 #endif /* ERROR_CHECK_BYTE_CODE */ |
| 2286 | 1471 const Opbyte *UNUSED (program_ptr), |
| 428 | 1472 Opcode opcode) |
| 1473 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1474 REGISTER int n; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1475 |
| 428 | 1476 switch (opcode) |
| 1477 { | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1478 |
| 428 | 1479 case Bsave_excursion: |
| 1480 record_unwind_protect (save_excursion_restore, | |
| 1481 save_excursion_save ()); | |
| 1482 break; | |
| 1483 | |
|
4775
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4717
diff
changeset
|
1484 /* 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
|
1485 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
|
1486 a macro. */ |
| 428 | 1487 case Bsave_window_excursion: |
| 1488 { | |
| 1489 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
|
1490 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
|
1491 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
|
1492 call0 (Qcurrent_window_configuration))); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1493 TOP_LVALUE = Fprogn (TOP); |
| 771 | 1494 unbind_to (count); |
| 428 | 1495 break; |
| 1496 } | |
| 1497 | |
| 1498 case Bsave_restriction: | |
| 1499 record_unwind_protect (save_restriction_restore, | |
| 844 | 1500 save_restriction_save (current_buffer)); |
| 428 | 1501 break; |
| 1502 | |
| 1503 case Bcatch: | |
| 1504 { | |
| 1505 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1506 TOP_LVALUE = internal_catch (TOP, Feval, arg, 0, 0, 0); |
| 428 | 1507 break; |
| 1508 } | |
| 1509 | |
| 1510 case Bskip_chars_backward: | |
| 1511 { | |
| 1512 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1513 TOP_LVALUE = Fskip_chars_backward (TOP, arg, Qnil); |
| 428 | 1514 break; |
| 1515 } | |
| 1516 | |
| 1517 case Bunwind_protect: | |
| 1518 record_unwind_protect (Fprogn, POP); | |
| 1519 break; | |
| 1520 | |
| 1521 case Bcondition_case: | |
| 1522 { | |
| 1523 Lisp_Object arg2 = POP; /* handlers */ | |
| 1524 Lisp_Object arg1 = POP; /* bodyform */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1525 TOP_LVALUE = condition_case_3 (arg1, TOP, arg2); |
| 428 | 1526 break; |
| 1527 } | |
| 1528 | |
| 1529 case Bset_marker: | |
| 1530 { | |
| 1531 Lisp_Object arg2 = POP; | |
| 1532 Lisp_Object arg1 = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1533 TOP_LVALUE = Fset_marker (TOP, arg1, arg2); |
| 428 | 1534 break; |
| 1535 } | |
| 1536 | |
| 1537 case Brem: | |
| 1538 { | |
| 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 = Frem (TOP, arg); |
| 428 | 1541 break; |
| 1542 } | |
| 1543 | |
| 1544 case Bmatch_beginning: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1545 TOP_LVALUE = Fmatch_beginning (TOP); |
| 428 | 1546 break; |
| 1547 | |
| 1548 case Bmatch_end: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1549 TOP_LVALUE = Fmatch_end (TOP); |
| 428 | 1550 break; |
| 1551 | |
| 1552 case Bupcase: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1553 TOP_LVALUE = Fupcase (TOP, Qnil); |
| 428 | 1554 break; |
| 1555 | |
| 1556 case Bdowncase: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1557 TOP_LVALUE = Fdowncase (TOP, Qnil); |
| 428 | 1558 break; |
| 1559 | |
| 1560 case Bfset: | |
| 1561 { | |
| 1562 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1563 TOP_LVALUE = Ffset (TOP, arg); |
| 428 | 1564 break; |
| 1565 } | |
| 1566 | |
| 1567 case Bstring_equal: | |
| 1568 { | |
| 1569 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1570 TOP_LVALUE = Fstring_equal (TOP, arg); |
| 428 | 1571 break; |
| 1572 } | |
| 1573 | |
| 1574 case Bstring_lessp: | |
| 1575 { | |
| 1576 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1577 TOP_LVALUE = Fstring_lessp (TOP, arg); |
| 428 | 1578 break; |
| 1579 } | |
| 1580 | |
|
5089
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4974
diff
changeset
|
1581 case Bsubseq: |
| 428 | 1582 { |
| 1583 Lisp_Object arg2 = POP; | |
| 1584 Lisp_Object arg1 = POP; | |
|
5089
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4974
diff
changeset
|
1585 TOP_LVALUE = Fsubseq (TOP, arg1, arg2); |
| 428 | 1586 break; |
| 1587 } | |
| 1588 | |
| 1589 case Bcurrent_column: | |
| 1590 PUSH (make_int (current_column (current_buffer))); | |
| 1591 break; | |
| 1592 | |
| 1593 case Bchar_after: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1594 TOP_LVALUE = Fchar_after (TOP, Qnil); |
| 428 | 1595 break; |
| 1596 | |
| 1597 case Bindent_to: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1598 TOP_LVALUE = Findent_to (TOP, Qnil, Qnil); |
| 428 | 1599 break; |
| 1600 | |
| 1601 case Bwiden: | |
| 1602 PUSH (Fwiden (Qnil)); | |
| 1603 break; | |
| 1604 | |
| 1605 case Bfollowing_char: | |
| 1606 PUSH (Ffollowing_char (Qnil)); | |
| 1607 break; | |
| 1608 | |
| 1609 case Bpreceding_char: | |
| 1610 PUSH (Fpreceding_char (Qnil)); | |
| 1611 break; | |
| 1612 | |
| 1613 case Beolp: | |
| 1614 PUSH (Feolp (Qnil)); | |
| 1615 break; | |
| 1616 | |
| 1617 case Beobp: | |
| 1618 PUSH (Feobp (Qnil)); | |
| 1619 break; | |
| 1620 | |
| 1621 case Bbolp: | |
| 1622 PUSH (Fbolp (Qnil)); | |
| 1623 break; | |
| 1624 | |
| 1625 case Bbobp: | |
| 1626 PUSH (Fbobp (Qnil)); | |
| 1627 break; | |
| 1628 | |
| 1629 case Bsave_current_buffer: | |
| 1630 record_unwind_protect (save_current_buffer_restore, | |
| 1631 Fcurrent_buffer ()); | |
| 1632 break; | |
| 1633 | |
| 1634 case Binteractive_p: | |
| 1635 PUSH (Finteractive_p ()); | |
| 1636 break; | |
| 1637 | |
| 1638 case Bforward_char: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1639 TOP_LVALUE = Fforward_char (TOP, Qnil); |
| 428 | 1640 break; |
| 1641 | |
| 1642 case Bforward_word: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1643 TOP_LVALUE = Fforward_word (TOP, Qnil); |
| 428 | 1644 break; |
| 1645 | |
| 1646 case Bforward_line: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1647 TOP_LVALUE = Fforward_line (TOP, Qnil); |
| 428 | 1648 break; |
| 1649 | |
| 1650 case Bchar_syntax: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1651 TOP_LVALUE = Fchar_syntax (TOP, Qnil); |
| 428 | 1652 break; |
| 1653 | |
| 1654 case Bbuffer_substring: | |
| 1655 { | |
| 1656 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1657 TOP_LVALUE = Fbuffer_substring (TOP, arg, Qnil); |
| 428 | 1658 break; |
| 1659 } | |
| 1660 | |
| 1661 case Bdelete_region: | |
| 1662 { | |
| 1663 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1664 TOP_LVALUE = Fdelete_region (TOP, arg, Qnil); |
| 428 | 1665 break; |
| 1666 } | |
| 1667 | |
| 1668 case Bnarrow_to_region: | |
| 1669 { | |
| 1670 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1671 TOP_LVALUE = Fnarrow_to_region (TOP, arg, Qnil); |
| 428 | 1672 break; |
| 1673 } | |
| 1674 | |
| 1675 case Bend_of_line: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1676 TOP_LVALUE = Fend_of_line (TOP, Qnil); |
| 428 | 1677 break; |
| 1678 | |
| 1679 case Btemp_output_buffer_setup: | |
| 1680 temp_output_buffer_setup (TOP); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1681 TOP_LVALUE = Vstandard_output; |
| 428 | 1682 break; |
| 1683 | |
| 1684 case Btemp_output_buffer_show: | |
| 1685 { | |
| 1686 Lisp_Object arg = POP; | |
| 1687 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
|
1688 TOP_LVALUE = arg; |
| 428 | 1689 /* GAG ME!! */ |
| 1690 /* pop binding of standard-output */ | |
| 771 | 1691 unbind_to (specpdl_depth() - 1); |
| 428 | 1692 break; |
| 1693 } | |
| 1694 | |
| 1695 case Bold_eq: | |
| 1696 { | |
| 1697 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1698 TOP_LVALUE = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil; |
| 428 | 1699 break; |
| 1700 } | |
| 1701 | |
| 1702 case Bold_memq: | |
| 1703 { | |
| 1704 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1705 TOP_LVALUE = Fold_memq (TOP, arg); |
| 428 | 1706 break; |
| 1707 } | |
| 1708 | |
| 1709 case Bold_equal: | |
| 1710 { | |
| 1711 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1712 TOP_LVALUE = Fold_equal (TOP, arg); |
| 428 | 1713 break; |
| 1714 } | |
| 1715 | |
| 1716 case Bold_member: | |
| 1717 { | |
| 1718 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1719 TOP_LVALUE = Fold_member (TOP, arg); |
| 428 | 1720 break; |
| 1721 } | |
| 1722 | |
| 1723 case Bold_assq: | |
| 1724 { | |
| 1725 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1726 TOP_LVALUE = Fold_assq (TOP, arg); |
| 428 | 1727 break; |
| 1728 } | |
| 1729 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1730 case Bbind_multiple_value_limits: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1731 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1732 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
|
1733 |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
1734 check_integer_range (upper, Qzero, |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
1735 make_integer (Vmultiple_values_limit)); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
1736 check_integer_range (first, Qzero, upper); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1737 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1738 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
|
1739 XINT (upper))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1740 PUSH (upper); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1741 PUSH (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1742 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1743 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1744 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1745 case Bmultiple_value_call: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1746 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1747 n = XINT (POP); |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1748 DISCARD_PRESERVING_MULTIPLE_VALUES_UNSAFE (n - 1); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1749 /* 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
|
1750 TOP_LVALUE = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1751 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
|
1752 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1753 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1754 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1755 case Bmultiple_value_list_internal: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1756 { |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1757 DISCARD_PRESERVING_MULTIPLE_VALUES_UNSAFE (3); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1758 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
|
1759 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1760 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1761 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1762 case Bthrow: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1763 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1764 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
|
1765 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1766 /* 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
|
1767 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
|
1768 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1769 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1770 |
| 428 | 1771 default: |
|
4914
1628e3b9601a
When aborting due to unknown opcode, output more descriptive msg
Ben Wing <ben@xemacs.org>
parents:
4910
diff
changeset
|
1772 { |
|
1628e3b9601a
When aborting due to unknown opcode, output more descriptive msg
Ben Wing <ben@xemacs.org>
parents:
4910
diff
changeset
|
1773 Ascbyte msg[100]; |
|
1628e3b9601a
When aborting due to unknown opcode, output more descriptive msg
Ben Wing <ben@xemacs.org>
parents:
4910
diff
changeset
|
1774 sprintf (msg, "Unknown opcode %d", opcode); |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1775 bytecode_abort_with_message (msg); |
|
4914
1628e3b9601a
When aborting due to unknown opcode, output more descriptive msg
Ben Wing <ben@xemacs.org>
parents:
4910
diff
changeset
|
1776 } |
| 428 | 1777 break; |
| 1778 } | |
| 1779 return stack_ptr; | |
| 1780 } | |
| 1781 | |
| 1782 | |
| 563 | 1783 DOESNT_RETURN |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4775
diff
changeset
|
1784 invalid_byte_code (const Ascbyte *reason, Lisp_Object frob) |
| 428 | 1785 { |
| 563 | 1786 signal_error (Qinvalid_byte_code, reason, frob); |
| 428 | 1787 } |
| 1788 | |
| 1789 /* Check for valid opcodes. Change this when adding new opcodes. */ | |
| 1790 static void | |
| 1791 check_opcode (Opcode opcode) | |
| 1792 { | |
| 1793 if ((opcode < Bvarref) || | |
| 1794 (opcode == 0251) || | |
| 1795 (opcode > Bassq && opcode < Bconstant)) | |
| 563 | 1796 invalid_byte_code ("invalid opcode in instruction stream", |
| 1797 make_int (opcode)); | |
| 428 | 1798 } |
| 1799 | |
| 1800 /* Check that IDX is a valid offset into the `constants' vector */ | |
| 1801 static void | |
| 1802 check_constants_index (int idx, Lisp_Object constants) | |
| 1803 { | |
| 1804 if (idx < 0 || idx >= XVECTOR_LENGTH (constants)) | |
| 563 | 1805 signal_ferror |
| 1806 (Qinvalid_byte_code, | |
| 1807 "reference %d to constants array out of range 0, %ld", | |
| 428 | 1808 idx, XVECTOR_LENGTH (constants) - 1); |
| 1809 } | |
| 1810 | |
| 1811 /* Get next character from Lisp instructions string. */ | |
| 563 | 1812 #define READ_INSTRUCTION_CHAR(lvalue) do { \ |
| 867 | 1813 (lvalue) = itext_ichar (ptr); \ |
| 1814 INC_IBYTEPTR (ptr); \ | |
| 563 | 1815 *icounts_ptr++ = program_ptr - program; \ |
| 1816 if (lvalue > UCHAR_MAX) \ | |
| 1817 invalid_byte_code \ | |
| 1818 ("Invalid character in byte code string", make_char (lvalue)); \ | |
| 428 | 1819 } while (0) |
| 1820 | |
| 1821 /* Get opcode from Lisp instructions string. */ | |
| 1822 #define READ_OPCODE do { \ | |
| 1823 unsigned int c; \ | |
| 1824 READ_INSTRUCTION_CHAR (c); \ | |
| 1825 opcode = (Opcode) c; \ | |
| 1826 } while (0) | |
| 1827 | |
| 1828 /* Get next operand, a uint8, from Lisp instructions string. */ | |
| 1829 #define READ_OPERAND_1 do { \ | |
| 1830 READ_INSTRUCTION_CHAR (arg); \ | |
| 1831 argsize = 1; \ | |
| 1832 } while (0) | |
| 1833 | |
| 1834 /* Get next operand, a uint16, from Lisp instructions string. */ | |
| 1835 #define READ_OPERAND_2 do { \ | |
| 1836 unsigned int arg1, arg2; \ | |
| 1837 READ_INSTRUCTION_CHAR (arg1); \ | |
| 1838 READ_INSTRUCTION_CHAR (arg2); \ | |
| 1839 arg = arg1 + (arg2 << 8); \ | |
| 1840 argsize = 2; \ | |
| 1841 } while (0) | |
| 1842 | |
| 1843 /* Write 1 byte to PTR, incrementing PTR */ | |
| 1844 #define WRITE_INT8(value, ptr) do { \ | |
| 1845 *((ptr)++) = (value); \ | |
| 1846 } while (0) | |
| 1847 | |
| 1848 /* Write 2 bytes to PTR, incrementing PTR */ | |
| 1849 #define WRITE_INT16(value, ptr) do { \ | |
| 1850 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \ | |
| 1851 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \ | |
| 1852 } while (0) | |
| 1853 | |
| 1854 /* We've changed our minds about the opcode we've already written. */ | |
| 1855 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode)) | |
| 1856 | |
| 1857 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */ | |
| 1858 #define WRITE_NARGS(base_opcode) do { \ | |
| 1859 if (arg <= 5) \ | |
| 1860 { \ | |
| 1861 REWRITE_OPCODE (base_opcode + arg); \ | |
| 1862 } \ | |
| 1863 else if (arg <= UCHAR_MAX) \ | |
| 1864 { \ | |
| 1865 REWRITE_OPCODE (base_opcode + 6); \ | |
| 1866 WRITE_INT8 (arg, program_ptr); \ | |
| 1867 } \ | |
| 1868 else \ | |
| 1869 { \ | |
| 1870 REWRITE_OPCODE (base_opcode + 7); \ | |
| 1871 WRITE_INT16 (arg, program_ptr); \ | |
| 1872 } \ | |
| 1873 } while (0) | |
| 1874 | |
| 1875 /* Encode a constants reference within the opcode, or as a 2-byte operand. */ | |
| 1876 #define WRITE_CONSTANT do { \ | |
| 1877 check_constants_index(arg, constants); \ | |
| 1878 if (arg <= UCHAR_MAX - Bconstant) \ | |
| 1879 { \ | |
| 1880 REWRITE_OPCODE (Bconstant + arg); \ | |
| 1881 } \ | |
| 1882 else \ | |
| 1883 { \ | |
| 1884 REWRITE_OPCODE (Bconstant2); \ | |
| 1885 WRITE_INT16 (arg, program_ptr); \ | |
| 1886 } \ | |
| 1887 } while (0) | |
| 1888 | |
| 1889 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr) | |
| 1890 | |
| 1891 /* Compile byte code instructions into free space provided by caller, with | |
| 1892 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte). | |
| 1893 Returns length of compiled code. */ | |
| 1894 static void | |
| 1895 optimize_byte_code (/* in */ | |
| 1896 Lisp_Object instructions, | |
| 1897 Lisp_Object constants, | |
| 1898 /* out */ | |
| 442 | 1899 Opbyte * const program, |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1900 Elemcount * const program_length, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1901 Elemcount * const varbind_count) |
| 428 | 1902 { |
| 647 | 1903 Bytecount instructions_length = XSTRING_LENGTH (instructions); |
| 665 | 1904 Elemcount comfy_size = (Elemcount) (2 * instructions_length); |
| 428 | 1905 |
| 442 | 1906 int * const icounts = alloca_array (int, comfy_size); |
| 428 | 1907 int * icounts_ptr = icounts; |
| 1908 | |
| 1909 /* We maintain a table of jumps in the source code. */ | |
| 1910 struct jump | |
| 1911 { | |
| 1912 int from; | |
| 1913 int to; | |
| 1914 }; | |
| 442 | 1915 struct jump * const jumps = alloca_array (struct jump, comfy_size); |
| 428 | 1916 struct jump *jumps_ptr = jumps; |
| 1917 | |
| 1918 Opbyte *program_ptr = program; | |
| 1919 | |
| 867 | 1920 const Ibyte *ptr = XSTRING_DATA (instructions); |
| 1921 const Ibyte * const end = ptr + instructions_length; | |
| 428 | 1922 |
| 1923 *varbind_count = 0; | |
| 1924 | |
| 1925 while (ptr < end) | |
| 1926 { | |
| 1927 Opcode opcode; | |
| 1928 int arg; | |
| 1929 int argsize = 0; | |
| 1930 READ_OPCODE; | |
| 1931 WRITE_OPCODE; | |
| 1932 | |
| 1933 switch (opcode) | |
| 1934 { | |
| 1935 Lisp_Object val; | |
| 1936 | |
| 1937 case Bvarref+7: READ_OPERAND_2; goto do_varref; | |
| 1938 case Bvarref+6: READ_OPERAND_1; goto do_varref; | |
| 1939 case Bvarref: case Bvarref+1: case Bvarref+2: | |
| 1940 case Bvarref+3: case Bvarref+4: case Bvarref+5: | |
| 1941 arg = opcode - Bvarref; | |
| 1942 do_varref: | |
| 1943 check_constants_index (arg, constants); | |
| 1944 val = XVECTOR_DATA (constants) [arg]; | |
| 1945 if (!SYMBOLP (val)) | |
| 563 | 1946 invalid_byte_code ("variable reference to non-symbol", val); |
| 428 | 1947 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val))) |
| 563 | 1948 invalid_byte_code ("variable reference to constant symbol", val); |
| 428 | 1949 WRITE_NARGS (Bvarref); |
| 1950 break; | |
| 1951 | |
| 1952 case Bvarset+7: READ_OPERAND_2; goto do_varset; | |
| 1953 case Bvarset+6: READ_OPERAND_1; goto do_varset; | |
| 1954 case Bvarset: case Bvarset+1: case Bvarset+2: | |
| 1955 case Bvarset+3: case Bvarset+4: case Bvarset+5: | |
| 1956 arg = opcode - Bvarset; | |
| 1957 do_varset: | |
| 1958 check_constants_index (arg, constants); | |
| 1959 val = XVECTOR_DATA (constants) [arg]; | |
| 1960 if (!SYMBOLP (val)) | |
| 563 | 1961 wtaerror ("attempt to set non-symbol", val); |
| 428 | 1962 if (EQ (val, Qnil) || EQ (val, Qt)) |
| 563 | 1963 signal_error (Qsetting_constant, 0, val); |
| 428 | 1964 /* Ignore assignments to keywords by converting to Bdiscard. |
| 1965 For backward compatibility only - we'd like to make this an error. */ | |
| 1966 if (SYMBOL_IS_KEYWORD (val)) | |
| 1967 REWRITE_OPCODE (Bdiscard); | |
| 1968 else | |
| 1969 WRITE_NARGS (Bvarset); | |
| 1970 break; | |
| 1971 | |
| 1972 case Bvarbind+7: READ_OPERAND_2; goto do_varbind; | |
| 1973 case Bvarbind+6: READ_OPERAND_1; goto do_varbind; | |
| 1974 case Bvarbind: case Bvarbind+1: case Bvarbind+2: | |
| 1975 case Bvarbind+3: case Bvarbind+4: case Bvarbind+5: | |
| 1976 arg = opcode - Bvarbind; | |
| 1977 do_varbind: | |
| 1978 (*varbind_count)++; | |
| 1979 check_constants_index (arg, constants); | |
| 1980 val = XVECTOR_DATA (constants) [arg]; | |
| 1981 if (!SYMBOLP (val)) | |
| 563 | 1982 wtaerror ("attempt to let-bind non-symbol", val); |
| 428 | 1983 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val))) |
| 563 | 1984 signal_error (Qsetting_constant, |
| 1985 "attempt to let-bind constant symbol", val); | |
| 428 | 1986 WRITE_NARGS (Bvarbind); |
| 1987 break; | |
| 1988 | |
| 1989 case Bcall+7: READ_OPERAND_2; goto do_call; | |
| 1990 case Bcall+6: READ_OPERAND_1; goto do_call; | |
| 1991 case Bcall: case Bcall+1: case Bcall+2: | |
| 1992 case Bcall+3: case Bcall+4: case Bcall+5: | |
| 1993 arg = opcode - Bcall; | |
| 1994 do_call: | |
| 1995 WRITE_NARGS (Bcall); | |
| 1996 break; | |
| 1997 | |
| 1998 case Bunbind+7: READ_OPERAND_2; goto do_unbind; | |
| 1999 case Bunbind+6: READ_OPERAND_1; goto do_unbind; | |
| 2000 case Bunbind: case Bunbind+1: case Bunbind+2: | |
| 2001 case Bunbind+3: case Bunbind+4: case Bunbind+5: | |
| 2002 arg = opcode - Bunbind; | |
| 2003 do_unbind: | |
| 2004 WRITE_NARGS (Bunbind); | |
| 2005 break; | |
| 2006 | |
| 2007 case Bgoto: | |
| 2008 case Bgotoifnil: | |
| 2009 case Bgotoifnonnil: | |
| 2010 case Bgotoifnilelsepop: | |
| 2011 case Bgotoifnonnilelsepop: | |
| 2012 READ_OPERAND_2; | |
| 2013 /* Make program_ptr-relative */ | |
| 2014 arg += icounts - (icounts_ptr - argsize); | |
| 2015 goto do_jump; | |
| 2016 | |
| 2017 case BRgoto: | |
| 2018 case BRgotoifnil: | |
| 2019 case BRgotoifnonnil: | |
| 2020 case BRgotoifnilelsepop: | |
| 2021 case BRgotoifnonnilelsepop: | |
| 2022 READ_OPERAND_1; | |
| 2023 /* Make program_ptr-relative */ | |
| 2024 arg -= 127; | |
| 2025 do_jump: | |
| 2026 /* Record program-relative goto addresses in `jumps' table */ | |
| 2027 jumps_ptr->from = icounts_ptr - icounts - argsize; | |
| 2028 jumps_ptr->to = jumps_ptr->from + arg; | |
| 2029 jumps_ptr++; | |
| 2030 if (arg >= -1 && arg <= argsize) | |
| 563 | 2031 invalid_byte_code ("goto instruction is its own target", Qunbound); |
| 428 | 2032 if (arg <= SCHAR_MIN || |
| 2033 arg > SCHAR_MAX) | |
| 2034 { | |
| 2035 if (argsize == 1) | |
| 2036 REWRITE_OPCODE (opcode + Bgoto - BRgoto); | |
| 2037 WRITE_INT16 (arg, program_ptr); | |
| 2038 } | |
| 2039 else | |
| 2040 { | |
| 2041 if (argsize == 2) | |
| 2042 REWRITE_OPCODE (opcode + BRgoto - Bgoto); | |
| 2043 WRITE_INT8 (arg, program_ptr); | |
| 2044 } | |
| 2045 break; | |
| 2046 | |
| 2047 case Bconstant2: | |
| 2048 READ_OPERAND_2; | |
| 2049 WRITE_CONSTANT; | |
| 2050 break; | |
| 2051 | |
| 2052 case BlistN: | |
| 2053 case BconcatN: | |
| 2054 case BinsertN: | |
| 2055 READ_OPERAND_1; | |
| 2056 WRITE_INT8 (arg, program_ptr); | |
| 2057 break; | |
| 2058 | |
| 2059 default: | |
| 2060 if (opcode < Bconstant) | |
| 2061 check_opcode (opcode); | |
| 2062 else | |
| 2063 { | |
| 2064 arg = opcode - Bconstant; | |
| 2065 WRITE_CONSTANT; | |
| 2066 } | |
| 2067 break; | |
| 2068 } | |
| 2069 } | |
| 2070 | |
| 2071 /* Fix up jumps table to refer to NEW offsets. */ | |
| 2072 { | |
| 2073 struct jump *j; | |
| 2074 for (j = jumps; j < jumps_ptr; j++) | |
| 2075 { | |
| 2076 #ifdef ERROR_CHECK_BYTE_CODE | |
| 2077 assert (j->from < icounts_ptr - icounts); | |
| 2078 assert (j->to < icounts_ptr - icounts); | |
| 2079 #endif | |
| 2080 j->from = icounts[j->from]; | |
| 2081 j->to = icounts[j->to]; | |
| 2082 #ifdef ERROR_CHECK_BYTE_CODE | |
| 2083 assert (j->from < program_ptr - program); | |
| 2084 assert (j->to < program_ptr - program); | |
| 2085 check_opcode ((Opcode) (program[j->from-1])); | |
| 2086 #endif | |
| 2087 check_opcode ((Opcode) (program[j->to])); | |
| 2088 } | |
| 2089 } | |
| 2090 | |
| 2091 /* Fixup jumps in byte-code until no more fixups needed */ | |
| 2092 { | |
| 2093 int more_fixups_needed = 1; | |
| 2094 | |
| 2095 while (more_fixups_needed) | |
| 2096 { | |
| 2097 struct jump *j; | |
| 2098 more_fixups_needed = 0; | |
| 2099 for (j = jumps; j < jumps_ptr; j++) | |
| 2100 { | |
| 2101 int from = j->from; | |
| 2102 int to = j->to; | |
| 2103 int jump = to - from; | |
| 2104 Opbyte *p = program + from; | |
| 2105 Opcode opcode = (Opcode) p[-1]; | |
| 2106 if (!more_fixups_needed) | |
| 2107 check_opcode ((Opcode) p[jump]); | |
| 2108 assert (to >= 0 && program + to < program_ptr); | |
| 2109 switch (opcode) | |
| 2110 { | |
| 2111 case Bgoto: | |
| 2112 case Bgotoifnil: | |
| 2113 case Bgotoifnonnil: | |
| 2114 case Bgotoifnilelsepop: | |
| 2115 case Bgotoifnonnilelsepop: | |
| 2116 WRITE_INT16 (jump, p); | |
| 2117 break; | |
| 2118 | |
| 2119 case BRgoto: | |
| 2120 case BRgotoifnil: | |
| 2121 case BRgotoifnonnil: | |
| 2122 case BRgotoifnilelsepop: | |
| 2123 case BRgotoifnonnilelsepop: | |
| 2124 if (jump > SCHAR_MIN && | |
| 2125 jump <= SCHAR_MAX) | |
| 2126 { | |
| 2127 WRITE_INT8 (jump, p); | |
| 2128 } | |
| 2129 else /* barf */ | |
| 2130 { | |
| 2131 struct jump *jj; | |
| 2132 for (jj = jumps; jj < jumps_ptr; jj++) | |
| 2133 { | |
| 2134 assert (jj->from < program_ptr - program); | |
| 2135 assert (jj->to < program_ptr - program); | |
| 2136 if (jj->from > from) jj->from++; | |
| 2137 if (jj->to > from) jj->to++; | |
| 2138 } | |
| 2139 p[-1] += Bgoto - BRgoto; | |
| 2140 more_fixups_needed = 1; | |
| 2141 memmove (p+1, p, program_ptr++ - p); | |
| 2142 WRITE_INT16 (jump, p); | |
| 2143 } | |
| 2144 break; | |
| 2145 | |
| 2146 default: | |
| 2500 | 2147 ABORT(); |
| 428 | 2148 break; |
| 2149 } | |
| 2150 } | |
| 2151 } | |
| 2152 } | |
| 2153 | |
| 2154 /* *program_ptr++ = 0; */ | |
| 2155 *program_length = program_ptr - program; | |
| 2156 } | |
| 2157 | |
| 2158 /* Optimize the byte code and store the optimized program, only | |
| 2159 understood by bytecode.c, in an opaque object in the | |
| 2160 instructions slot of the Compiled_Function object. */ | |
| 2161 void | |
| 2162 optimize_compiled_function (Lisp_Object compiled_function) | |
| 2163 { | |
| 2164 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function); | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2165 Elemcount program_length; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2166 Elemcount varbind_count; |
| 428 | 2167 Opbyte *program; |
| 2168 | |
| 1737 | 2169 { |
| 2170 int minargs = 0, maxargs = 0, totalargs = 0; | |
| 2171 int optional_p = 0, rest_p = 0, i = 0; | |
| 2172 { | |
| 2173 LIST_LOOP_2 (arg, f->arglist) | |
| 2174 { | |
| 2175 if (EQ (arg, Qand_optional)) | |
| 2176 optional_p = 1; | |
| 2177 else if (EQ (arg, Qand_rest)) | |
| 2178 rest_p = 1; | |
| 2179 else | |
| 2180 { | |
| 2181 if (rest_p) | |
| 2182 { | |
| 2183 maxargs = MANY; | |
| 2184 totalargs++; | |
| 2185 break; | |
| 2186 } | |
| 2187 if (!optional_p) | |
| 2188 minargs++; | |
| 2189 maxargs++; | |
| 2190 totalargs++; | |
| 2191 } | |
| 2192 } | |
| 2193 } | |
| 2194 | |
| 2195 if (totalargs) | |
| 3092 | 2196 #ifdef NEW_GC |
| 2197 f->arguments = make_compiled_function_args (totalargs); | |
| 2198 #else /* not NEW_GC */ | |
| 1737 | 2199 f->args = xnew_array (Lisp_Object, totalargs); |
| 3092 | 2200 #endif /* not NEW_GC */ |
| 1737 | 2201 |
| 2202 { | |
| 2203 LIST_LOOP_2 (arg, f->arglist) | |
| 2204 { | |
| 2205 if (!EQ (arg, Qand_optional) && !EQ (arg, Qand_rest)) | |
| 3092 | 2206 #ifdef NEW_GC |
| 2207 XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i++] = arg; | |
| 2208 #else /* not NEW_GC */ | |
| 1737 | 2209 f->args[i++] = arg; |
| 3092 | 2210 #endif /* not NEW_GC */ |
| 1737 | 2211 } |
| 2212 } | |
| 2213 | |
| 2214 f->max_args = maxargs; | |
| 2215 f->min_args = minargs; | |
| 2216 f->args_in_array = totalargs; | |
| 2217 } | |
| 2218 | |
| 428 | 2219 /* If we have not actually read the bytecode string |
| 2220 and constants vector yet, fetch them from the file. */ | |
| 2221 if (CONSP (f->instructions)) | |
| 2222 Ffetch_bytecode (compiled_function); | |
| 2223 | |
| 2224 if (STRINGP (f->instructions)) | |
| 2225 { | |
| 826 | 2226 /* XSTRING_LENGTH() is more efficient than string_char_length(), |
| 428 | 2227 which would be slightly more `proper' */ |
| 2228 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions)); | |
| 2229 optimize_byte_code (f->instructions, f->constants, | |
| 2230 program, &program_length, &varbind_count); | |
| 2500 | 2231 f->specpdl_depth = (unsigned short) (XINT (Flength (f->arglist)) + |
| 2232 varbind_count); | |
| 428 | 2233 f->instructions = |
| 440 | 2234 make_opaque (program, program_length * sizeof (Opbyte)); |
| 428 | 2235 } |
| 2236 | |
| 2237 assert (OPAQUEP (f->instructions)); | |
| 2238 } | |
| 2239 | |
| 2240 /************************************************************************/ | |
| 2241 /* The compiled-function object type */ | |
| 2242 /************************************************************************/ | |
| 3092 | 2243 |
| 428 | 2244 static void |
| 2245 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun, | |
| 2246 int escapeflag) | |
| 2247 { | |
| 2248 /* This function can GC */ | |
| 2249 Lisp_Compiled_Function *f = | |
| 2250 XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */ | |
| 2251 int docp = f->flags.documentationp; | |
| 2252 int intp = f->flags.interactivep; | |
| 2253 struct gcpro gcpro1, gcpro2; | |
| 2254 GCPRO2 (obj, printcharfun); | |
| 2255 | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2256 write_ascstring (printcharfun, print_readably ? "#[" : |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2257 "#<compiled-function "); |
| 428 | 2258 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK |
| 2259 if (!print_readably) | |
| 2260 { | |
| 2261 Lisp_Object ann = compiled_function_annotation (f); | |
| 2262 if (!NILP (ann)) | |
| 800 | 2263 write_fmt_string_lisp (printcharfun, "(from %S) ", 1, ann); |
| 428 | 2264 } |
| 2265 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ | |
| 2266 /* COMPILED_ARGLIST = 0 */ | |
| 2267 print_internal (compiled_function_arglist (f), printcharfun, escapeflag); | |
| 2268 | |
| 2269 /* COMPILED_INSTRUCTIONS = 1 */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4775
diff
changeset
|
2270 write_ascstring (printcharfun, " "); |
| 428 | 2271 { |
| 2272 struct gcpro ngcpro1; | |
| 2273 Lisp_Object instructions = compiled_function_instructions (f); | |
| 2274 NGCPRO1 (instructions); | |
| 2275 if (STRINGP (instructions) && !print_readably) | |
| 2276 { | |
| 2277 /* We don't usually want to see that junk in the bytecode. */ | |
| 800 | 2278 write_fmt_string (printcharfun, "\"...(%ld)\"", |
| 826 | 2279 (long) string_char_length (instructions)); |
| 428 | 2280 } |
| 2281 else | |
| 2282 print_internal (instructions, printcharfun, escapeflag); | |
| 2283 NUNGCPRO; | |
| 2284 } | |
| 2285 | |
| 2286 /* COMPILED_CONSTANTS = 2 */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4775
diff
changeset
|
2287 write_ascstring (printcharfun, " "); |
| 428 | 2288 print_internal (compiled_function_constants (f), printcharfun, escapeflag); |
| 2289 | |
| 2290 /* COMPILED_STACK_DEPTH = 3 */ | |
| 800 | 2291 write_fmt_string (printcharfun, " %d", compiled_function_stack_depth (f)); |
| 428 | 2292 |
| 2293 /* COMPILED_DOC_STRING = 4 */ | |
| 2294 if (docp || intp) | |
| 2295 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4775
diff
changeset
|
2296 write_ascstring (printcharfun, " "); |
| 428 | 2297 print_internal (compiled_function_documentation (f), printcharfun, |
| 2298 escapeflag); | |
| 2299 } | |
| 2300 | |
| 2301 /* COMPILED_INTERACTIVE = 5 */ | |
| 2302 if (intp) | |
| 2303 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4775
diff
changeset
|
2304 write_ascstring (printcharfun, " "); |
| 428 | 2305 print_internal (compiled_function_interactive (f), printcharfun, |
| 2306 escapeflag); | |
| 2307 } | |
| 2308 | |
| 2309 UNGCPRO; | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2310 if (print_readably) |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2311 write_ascstring (printcharfun, "]"); |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2312 else |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2313 write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); |
| 428 | 2314 } |
| 2315 | |
| 2316 | |
| 2317 static Lisp_Object | |
| 2318 mark_compiled_function (Lisp_Object obj) | |
| 2319 { | |
| 2320 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); | |
| 814 | 2321 int i; |
| 428 | 2322 |
| 2323 mark_object (f->instructions); | |
| 2324 mark_object (f->arglist); | |
| 2325 mark_object (f->doc_and_interactive); | |
| 2326 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 2327 mark_object (f->annotated); | |
| 2328 #endif | |
| 814 | 2329 for (i = 0; i < f->args_in_array; i++) |
| 3092 | 2330 #ifdef NEW_GC |
| 2331 mark_object (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i]); | |
| 2332 #else /* not NEW_GC */ | |
| 814 | 2333 mark_object (f->args[i]); |
| 3092 | 2334 #endif /* not NEW_GC */ |
| 814 | 2335 |
| 428 | 2336 /* tail-recurse on constants */ |
| 2337 return f->constants; | |
| 2338 } | |
| 2339 | |
| 2340 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
2341 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
2342 int UNUSED (foldcase)) |
| 428 | 2343 { |
| 2344 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1); | |
| 2345 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2); | |
| 2346 return | |
| 2347 (f1->flags.documentationp == f2->flags.documentationp && | |
| 2348 f1->flags.interactivep == f2->flags.interactivep && | |
| 2349 f1->flags.domainp == f2->flags.domainp && /* I18N3 */ | |
| 2350 internal_equal (compiled_function_instructions (f1), | |
| 2351 compiled_function_instructions (f2), depth + 1) && | |
| 2352 internal_equal (f1->constants, f2->constants, depth + 1) && | |
| 2353 internal_equal (f1->arglist, f2->arglist, depth + 1) && | |
| 2354 internal_equal (f1->doc_and_interactive, | |
| 2355 f2->doc_and_interactive, depth + 1)); | |
| 2356 } | |
| 2357 | |
| 665 | 2358 static Hashcode |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
2359 compiled_function_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) |
| 428 | 2360 { |
| 2361 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); | |
| 2362 return HASH3 ((f->flags.documentationp << 2) + | |
| 2363 (f->flags.interactivep << 1) + | |
| 2364 f->flags.domainp, | |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
2365 internal_hash (f->instructions, depth + 1, 0), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
2366 internal_hash (f->constants, depth + 1, 0)); |
| 428 | 2367 } |
| 2368 | |
| 1204 | 2369 static const struct memory_description compiled_function_description[] = { |
| 814 | 2370 { XD_INT, offsetof (Lisp_Compiled_Function, args_in_array) }, |
| 3092 | 2371 #ifdef NEW_GC |
| 2372 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arguments) }, | |
| 2373 #else /* not NEW_GC */ | |
| 2374 { XD_BLOCK_PTR, offsetof (Lisp_Compiled_Function, args), | |
| 2551 | 2375 XD_INDIRECT (0, 0), { &lisp_object_description } }, |
| 3092 | 2376 #endif /* not NEW_GC */ |
| 440 | 2377 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) }, |
| 2378 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) }, | |
| 2379 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) }, | |
| 2380 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) }, | |
| 428 | 2381 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK |
| 440 | 2382 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) }, |
| 428 | 2383 #endif |
| 2384 { XD_END } | |
| 2385 }; | |
| 2386 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2387 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("compiled-function", compiled_function, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
2388 mark_compiled_function, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
2389 print_compiled_function, 0, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
2390 compiled_function_equal, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
2391 compiled_function_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
2392 compiled_function_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
2393 Lisp_Compiled_Function); |
| 3092 | 2394 |
| 428 | 2395 |
| 2396 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /* | |
| 2397 Return t if OBJECT is a byte-compiled function object. | |
| 2398 */ | |
| 2399 (object)) | |
| 2400 { | |
| 2401 return COMPILED_FUNCTIONP (object) ? Qt : Qnil; | |
| 2402 } | |
| 2403 | |
| 2404 /************************************************************************/ | |
| 2405 /* compiled-function object accessor functions */ | |
| 2406 /************************************************************************/ | |
| 2407 | |
| 2408 Lisp_Object | |
| 2409 compiled_function_arglist (Lisp_Compiled_Function *f) | |
| 2410 { | |
| 2411 return f->arglist; | |
| 2412 } | |
| 2413 | |
| 2414 Lisp_Object | |
| 2415 compiled_function_instructions (Lisp_Compiled_Function *f) | |
| 2416 { | |
| 2417 if (! OPAQUEP (f->instructions)) | |
| 2418 return f->instructions; | |
| 2419 | |
| 2420 { | |
| 2421 /* Invert action performed by optimize_byte_code() */ | |
| 2422 Lisp_Opaque *opaque = XOPAQUE (f->instructions); | |
| 2423 | |
| 867 | 2424 Ibyte * const buffer = |
| 2367 | 2425 alloca_ibytes (OPAQUE_SIZE (opaque) * MAX_ICHAR_LEN); |
| 867 | 2426 Ibyte *bp = buffer; |
| 428 | 2427 |
| 442 | 2428 const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque); |
| 2429 const Opbyte *program_ptr = program; | |
| 2430 const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque); | |
| 428 | 2431 |
| 2432 while (program_ptr < program_end) | |
| 2433 { | |
| 2434 Opcode opcode = (Opcode) READ_UINT_1; | |
| 867 | 2435 bp += set_itext_ichar (bp, opcode); |
| 428 | 2436 switch (opcode) |
| 2437 { | |
| 2438 case Bvarref+7: | |
| 2439 case Bvarset+7: | |
| 2440 case Bvarbind+7: | |
| 2441 case Bcall+7: | |
| 2442 case Bunbind+7: | |
| 2443 case Bconstant2: | |
| 867 | 2444 bp += set_itext_ichar (bp, READ_UINT_1); |
| 2445 bp += set_itext_ichar (bp, READ_UINT_1); | |
| 428 | 2446 break; |
| 2447 | |
| 2448 case Bvarref+6: | |
| 2449 case Bvarset+6: | |
| 2450 case Bvarbind+6: | |
| 2451 case Bcall+6: | |
| 2452 case Bunbind+6: | |
| 2453 case BlistN: | |
| 2454 case BconcatN: | |
| 2455 case BinsertN: | |
| 867 | 2456 bp += set_itext_ichar (bp, READ_UINT_1); |
| 428 | 2457 break; |
| 2458 | |
| 2459 case Bgoto: | |
| 2460 case Bgotoifnil: | |
| 2461 case Bgotoifnonnil: | |
| 2462 case Bgotoifnilelsepop: | |
| 2463 case Bgotoifnonnilelsepop: | |
| 2464 { | |
| 2465 int jump = READ_INT_2; | |
| 2466 Opbyte buf2[2]; | |
| 2467 Opbyte *buf2p = buf2; | |
| 2468 /* Convert back to program-relative address */ | |
| 2469 WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p); | |
| 867 | 2470 bp += set_itext_ichar (bp, buf2[0]); |
| 2471 bp += set_itext_ichar (bp, buf2[1]); | |
| 428 | 2472 break; |
| 2473 } | |
| 2474 | |
| 2475 case BRgoto: | |
| 2476 case BRgotoifnil: | |
| 2477 case BRgotoifnonnil: | |
| 2478 case BRgotoifnilelsepop: | |
| 2479 case BRgotoifnonnilelsepop: | |
| 867 | 2480 bp += set_itext_ichar (bp, READ_INT_1 + 127); |
| 428 | 2481 break; |
| 2482 | |
| 2483 default: | |
| 2484 break; | |
| 2485 } | |
| 2486 } | |
| 2487 return make_string (buffer, bp - buffer); | |
| 2488 } | |
| 2489 } | |
| 2490 | |
| 2491 Lisp_Object | |
| 2492 compiled_function_constants (Lisp_Compiled_Function *f) | |
| 2493 { | |
| 2494 return f->constants; | |
| 2495 } | |
| 2496 | |
| 2497 int | |
| 2498 compiled_function_stack_depth (Lisp_Compiled_Function *f) | |
| 2499 { | |
| 2500 return f->stack_depth; | |
| 2501 } | |
| 2502 | |
| 2503 /* The compiled_function->doc_and_interactive slot uses the minimal | |
| 2504 number of conses, based on compiled_function->flags; it may take | |
| 2505 any of the following forms: | |
| 2506 | |
| 2507 doc | |
| 2508 interactive | |
| 2509 domain | |
| 2510 (doc . interactive) | |
| 2511 (doc . domain) | |
| 2512 (interactive . domain) | |
| 2513 (doc . (interactive . domain)) | |
| 2514 */ | |
| 2515 | |
| 2516 /* Caller must check flags.interactivep first */ | |
| 2517 Lisp_Object | |
| 2518 compiled_function_interactive (Lisp_Compiled_Function *f) | |
| 2519 { | |
| 2520 assert (f->flags.interactivep); | |
| 2521 if (f->flags.documentationp && f->flags.domainp) | |
| 2522 return XCAR (XCDR (f->doc_and_interactive)); | |
| 2523 else if (f->flags.documentationp) | |
| 2524 return XCDR (f->doc_and_interactive); | |
| 2525 else if (f->flags.domainp) | |
| 2526 return XCAR (f->doc_and_interactive); | |
| 2527 else | |
| 2528 return f->doc_and_interactive; | |
| 2529 } | |
| 2530 | |
| 2531 /* Caller need not check flags.documentationp first */ | |
| 2532 Lisp_Object | |
| 2533 compiled_function_documentation (Lisp_Compiled_Function *f) | |
| 2534 { | |
| 2535 if (! f->flags.documentationp) | |
| 2536 return Qnil; | |
| 2537 else if (f->flags.interactivep && f->flags.domainp) | |
| 2538 return XCAR (f->doc_and_interactive); | |
| 2539 else if (f->flags.interactivep) | |
| 2540 return XCAR (f->doc_and_interactive); | |
| 2541 else if (f->flags.domainp) | |
| 2542 return XCAR (f->doc_and_interactive); | |
| 2543 else | |
| 2544 return f->doc_and_interactive; | |
| 2545 } | |
| 2546 | |
| 2547 /* Caller need not check flags.domainp first */ | |
| 2548 Lisp_Object | |
| 2549 compiled_function_domain (Lisp_Compiled_Function *f) | |
| 2550 { | |
| 2551 if (! f->flags.domainp) | |
| 2552 return Qnil; | |
| 2553 else if (f->flags.documentationp && f->flags.interactivep) | |
| 2554 return XCDR (XCDR (f->doc_and_interactive)); | |
| 2555 else if (f->flags.documentationp) | |
| 2556 return XCDR (f->doc_and_interactive); | |
| 2557 else if (f->flags.interactivep) | |
| 2558 return XCDR (f->doc_and_interactive); | |
| 2559 else | |
| 2560 return f->doc_and_interactive; | |
| 2561 } | |
| 2562 | |
| 2563 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 2564 | |
| 2565 Lisp_Object | |
| 2566 compiled_function_annotation (Lisp_Compiled_Function *f) | |
| 2567 { | |
| 2568 return f->annotated; | |
| 2569 } | |
| 2570 | |
| 2571 #endif | |
| 2572 | |
|
5206
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2573 /* used only by Snarf-documentation. */ |
| 428 | 2574 void |
| 2575 set_compiled_function_documentation (Lisp_Compiled_Function *f, | |
| 2576 Lisp_Object new_doc) | |
| 2577 { | |
| 2578 assert (INTP (new_doc) || STRINGP (new_doc)); | |
| 2579 | |
|
5206
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2580 if (f->flags.documentationp) |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2581 { |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2582 if (f->flags.interactivep && f->flags.domainp) |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2583 XCAR (f->doc_and_interactive) = new_doc; |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2584 else if (f->flags.interactivep) |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2585 XCAR (f->doc_and_interactive) = new_doc; |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2586 else if (f->flags.domainp) |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2587 XCAR (f->doc_and_interactive) = new_doc; |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2588 else |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2589 f->doc_and_interactive = new_doc; |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2590 } |
| 428 | 2591 else |
|
5206
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2592 { |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2593 f->flags.documentationp = 1; |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2594 if (f->flags.interactivep || f->flags.domainp) |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2595 { |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2596 f->doc_and_interactive = Fcons (new_doc, f->doc_and_interactive); |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2597 } |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2598 else |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2599 { |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2600 f->doc_and_interactive = new_doc; |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2601 } |
|
39d74978fd32
Keep around file info for dumped functions and variables without docstrings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2602 } |
| 428 | 2603 } |
| 2604 | |
| 2605 | |
| 2606 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /* | |
| 2607 Return the argument list of the compiled-function object FUNCTION. | |
| 2608 */ | |
| 2609 (function)) | |
| 2610 { | |
| 2611 CHECK_COMPILED_FUNCTION (function); | |
| 2612 return compiled_function_arglist (XCOMPILED_FUNCTION (function)); | |
| 2613 } | |
| 2614 | |
| 2615 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /* | |
| 2616 Return the byte-opcode string of the compiled-function object FUNCTION. | |
| 2617 */ | |
| 2618 (function)) | |
| 2619 { | |
| 2620 CHECK_COMPILED_FUNCTION (function); | |
| 2621 return compiled_function_instructions (XCOMPILED_FUNCTION (function)); | |
| 2622 } | |
| 2623 | |
| 2624 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /* | |
| 2625 Return the constants vector of the compiled-function object FUNCTION. | |
| 2626 */ | |
| 2627 (function)) | |
| 2628 { | |
| 2629 CHECK_COMPILED_FUNCTION (function); | |
| 2630 return compiled_function_constants (XCOMPILED_FUNCTION (function)); | |
| 2631 } | |
| 2632 | |
| 2633 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /* | |
| 444 | 2634 Return the maximum stack depth of the compiled-function object FUNCTION. |
| 428 | 2635 */ |
| 2636 (function)) | |
| 2637 { | |
| 2638 CHECK_COMPILED_FUNCTION (function); | |
| 2639 return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function))); | |
| 2640 } | |
| 2641 | |
| 2642 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /* | |
| 2643 Return the doc string of the compiled-function object FUNCTION, if available. | |
| 2644 Functions that had their doc strings snarfed into the DOC file will have | |
| 2645 an integer returned instead of a string. | |
| 2646 */ | |
| 2647 (function)) | |
| 2648 { | |
| 2649 CHECK_COMPILED_FUNCTION (function); | |
| 2650 return compiled_function_documentation (XCOMPILED_FUNCTION (function)); | |
| 2651 } | |
| 2652 | |
| 2653 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /* | |
| 2654 Return the interactive spec of the compiled-function object FUNCTION, or nil. | |
| 2655 If non-nil, the return value will be a list whose first element is | |
| 2656 `interactive' and whose second element is the interactive spec. | |
| 2657 */ | |
| 2658 (function)) | |
| 2659 { | |
| 2660 CHECK_COMPILED_FUNCTION (function); | |
| 2661 return XCOMPILED_FUNCTION (function)->flags.interactivep | |
| 2662 ? list2 (Qinteractive, | |
| 2663 compiled_function_interactive (XCOMPILED_FUNCTION (function))) | |
| 2664 : Qnil; | |
| 2665 } | |
| 2666 | |
| 2667 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 2668 | |
| 826 | 2669 DEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /* |
| 428 | 2670 Return the annotation of the compiled-function object FUNCTION, or nil. |
| 2671 The annotation is a piece of information indicating where this | |
| 2672 compiled-function object came from. Generally this will be | |
| 2673 a symbol naming a function; or a string naming a file, if the | |
| 2674 compiled-function object was not defined in a function; or nil, | |
| 2675 if the compiled-function object was not created as a result of | |
| 2676 a `load'. | |
| 2677 */ | |
| 2678 (function)) | |
| 2679 { | |
| 2680 CHECK_COMPILED_FUNCTION (function); | |
| 2681 return compiled_function_annotation (XCOMPILED_FUNCTION (function)); | |
| 2682 } | |
| 2683 | |
| 2684 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ | |
| 2685 | |
| 2686 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /* | |
| 2687 Return the domain of the compiled-function object FUNCTION, or nil. | |
| 2688 This is only meaningful if I18N3 was enabled when emacs was compiled. | |
| 2689 */ | |
| 2690 (function)) | |
| 2691 { | |
| 2692 CHECK_COMPILED_FUNCTION (function); | |
| 2693 return XCOMPILED_FUNCTION (function)->flags.domainp | |
| 2694 ? compiled_function_domain (XCOMPILED_FUNCTION (function)) | |
| 2695 : Qnil; | |
| 2696 } | |
| 2697 | |
| 2698 | |
| 2699 | |
| 2700 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /* | |
| 2701 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now. | |
| 2702 */ | |
| 2703 (function)) | |
| 2704 { | |
| 2705 Lisp_Compiled_Function *f; | |
| 2706 CHECK_COMPILED_FUNCTION (function); | |
| 2707 f = XCOMPILED_FUNCTION (function); | |
| 2708 | |
| 2709 if (OPAQUEP (f->instructions) || STRINGP (f->instructions)) | |
| 2710 return function; | |
| 2711 | |
| 2712 if (CONSP (f->instructions)) | |
| 2713 { | |
| 2714 Lisp_Object tem = read_doc_string (f->instructions); | |
| 2715 if (!CONSP (tem)) | |
| 563 | 2716 signal_error (Qinvalid_byte_code, |
| 2717 "Invalid lazy-loaded byte code", tem); | |
| 428 | 2718 /* v18 or v19 bytecode file. Need to Ebolify. */ |
| 2719 if (f->flags.ebolified && VECTORP (XCDR (tem))) | |
| 2720 ebolify_bytecode_constants (XCDR (tem)); | |
| 2721 f->instructions = XCAR (tem); | |
| 2722 f->constants = XCDR (tem); | |
| 2723 return function; | |
| 2724 } | |
| 2500 | 2725 ABORT (); |
| 801 | 2726 return Qnil; /* not (usually) reached */ |
| 428 | 2727 } |
| 2728 | |
| 2729 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /* | |
| 2730 Convert compiled function FUNCTION into an optimized internal form. | |
| 2731 */ | |
| 2732 (function)) | |
| 2733 { | |
| 2734 Lisp_Compiled_Function *f; | |
| 2735 CHECK_COMPILED_FUNCTION (function); | |
| 2736 f = XCOMPILED_FUNCTION (function); | |
| 2737 | |
| 2738 if (OPAQUEP (f->instructions)) /* Already optimized? */ | |
| 2739 return Qnil; | |
| 2740 | |
| 2741 optimize_compiled_function (function); | |
| 2742 return Qnil; | |
| 2743 } | |
| 2744 | |
| 2745 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /* | |
| 2746 Function used internally in byte-compiled code. | |
| 2747 First argument INSTRUCTIONS is a string of byte code. | |
| 2748 Second argument CONSTANTS is a vector of constants. | |
| 2749 Third argument STACK-DEPTH is the maximum stack depth used in this function. | |
| 2750 If STACK-DEPTH is incorrect, Emacs may crash. | |
| 2751 */ | |
| 2752 (instructions, constants, stack_depth)) | |
| 2753 { | |
| 2754 /* This function can GC */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2755 Elemcount varbind_count; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2756 Elemcount program_length; |
| 428 | 2757 Opbyte *program; |
| 2758 | |
| 2759 CHECK_STRING (instructions); | |
| 2760 CHECK_VECTOR (constants); | |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2761 check_integer_range (stack_depth, Qzero, make_int (USHRT_MAX)); |
| 428 | 2762 |
| 2763 /* Optimize the `instructions' string, just like when executing a | |
| 2764 regular compiled function, but don't save it for later since this is | |
| 2765 likely to only be executed once. */ | |
| 2766 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions)); | |
| 2767 optimize_byte_code (instructions, constants, program, | |
| 2768 &program_length, &varbind_count); | |
| 2769 SPECPDL_RESERVE (varbind_count); | |
| 2770 return execute_optimized_program (program, | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2771 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2772 program_length, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2773 #endif |
| 428 | 2774 XINT (stack_depth), |
| 2775 XVECTOR_DATA (constants)); | |
| 2776 } | |
| 2777 | |
| 2778 | |
| 2779 void | |
| 2780 syms_of_bytecode (void) | |
| 2781 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
2720
diff
changeset
|
2782 INIT_LISP_OBJECT (compiled_function); |
| 3092 | 2783 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2784 INIT_LISP_OBJECT (compiled_function_args); |
| 3092 | 2785 #endif /* NEW_GC */ |
| 442 | 2786 |
| 2787 DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state); | |
| 563 | 2788 DEFSYMBOL (Qbyte_code); |
| 2789 DEFSYMBOL_MULTIWORD_PREDICATE (Qcompiled_functionp); | |
| 428 | 2790 |
| 2791 DEFSUBR (Fbyte_code); | |
| 2792 DEFSUBR (Ffetch_bytecode); | |
| 2793 DEFSUBR (Foptimize_compiled_function); | |
| 2794 | |
| 2795 DEFSUBR (Fcompiled_function_p); | |
| 2796 DEFSUBR (Fcompiled_function_instructions); | |
| 2797 DEFSUBR (Fcompiled_function_constants); | |
| 2798 DEFSUBR (Fcompiled_function_stack_depth); | |
| 2799 DEFSUBR (Fcompiled_function_arglist); | |
| 2800 DEFSUBR (Fcompiled_function_interactive); | |
| 2801 DEFSUBR (Fcompiled_function_doc_string); | |
| 2802 DEFSUBR (Fcompiled_function_domain); | |
| 2803 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 2804 DEFSUBR (Fcompiled_function_annotation); | |
| 2805 #endif | |
| 2806 | |
| 2807 #ifdef BYTE_CODE_METER | |
| 563 | 2808 DEFSYMBOL (Qbyte_code_meter); |
| 428 | 2809 #endif |
| 2810 } | |
| 2811 | |
| 2812 void | |
| 2813 vars_of_bytecode (void) | |
| 2814 { | |
| 2815 #ifdef BYTE_CODE_METER | |
| 2816 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /* | |
| 2817 A vector of vectors which holds a histogram of byte code usage. | |
| 2818 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte | |
| 2819 opcode CODE has been executed. | |
| 2820 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0, | |
| 2821 indicates how many times the byte opcodes CODE1 and CODE2 have been | |
| 2822 executed in succession. | |
| 2823 */ ); | |
| 2824 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /* | |
| 2825 If non-nil, keep profiling information on byte code usage. | |
| 2826 The variable `byte-code-meter' indicates how often each byte opcode is used. | |
| 2827 If a symbol has a property named `byte-code-meter' whose value is an | |
| 2828 integer, it is incremented each time that symbol's function is called. | |
| 2829 */ ); | |
| 2830 | |
| 2831 byte_metering_on = 0; | |
| 2832 Vbyte_code_meter = make_vector (256, Qzero); | |
| 2833 { | |
| 2834 int i = 256; | |
| 2835 while (i--) | |
| 2836 XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero); | |
| 2837 } | |
| 2838 #endif /* BYTE_CODE_METER */ | |
| 2839 } | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2840 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2841 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2842 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2843 /* Initialize the opcodes in the table that correspond to a base opcode |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2844 plus an offset (except for Bconstant). */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2845 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2846 static void |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2847 init_opcode_table_multi_op (Opcode op) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2848 { |
| 5091 | 2849 const Ascbyte *base = opcode_name_table[op]; |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2850 Ascbyte temp[300]; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2851 int i; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2852 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2853 for (i = 1; i < 7; i++) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2854 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2855 assert (!opcode_name_table[op + i]); |
| 5091 | 2856 sprintf (temp, "%s+%d", base, i); |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2857 opcode_name_table[op + i] = xstrdup (temp); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2858 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2859 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2860 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2861 #endif /* ERROR_CHECK_BYTE_CODE */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2862 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2863 void |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2864 reinit_vars_of_bytecode (void) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2865 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2866 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2867 int i; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2868 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2869 #define OPCODE(sym, val) opcode_name_table[val] = xstrdup (#sym); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2870 #include "bytecode-ops.h" |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2871 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2872 for (i = 0; i < countof (opcode_name_table); i++) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2873 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2874 int j; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2875 Ascbyte *name = opcode_name_table[i]; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2876 if (name) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2877 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2878 Bytecount len = strlen (name); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2879 /* Prettify the name by converting underscores to hyphens, similar |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2880 to what happens with DEFSYMBOL. */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2881 for (j = 0; j < len; j++) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2882 if (name[j] == '_') |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2883 name[j] = '-'; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2884 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2885 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2886 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2887 init_opcode_table_multi_op (Bvarref); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2888 init_opcode_table_multi_op (Bvarset); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2889 init_opcode_table_multi_op (Bvarbind); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2890 init_opcode_table_multi_op (Bcall); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2891 init_opcode_table_multi_op (Bunbind); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2892 #endif /* ERROR_CHECK_BYTE_CODE */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2893 } |