Mercurial > hg > xemacs-beta
annotate src/eval.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 | 39304a35b6b3 |
| children | 0af042a0c116 |
| rev | line source |
|---|---|
| 428 | 1 /* Evaluator for XEmacs Lisp interpreter. |
| 2 Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Sun Microsystems, Inc. | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
4 Copyright (C) 2000, 2001, 2002, 2003, 2004, 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: FSF 19.30 (except for Fsignal), Mule 2.0. */ | |
| 24 | |
| 853 | 25 /* Authorship: |
| 26 | |
| 27 Based on code from pre-release FSF 19, c. 1991. | |
| 28 Some work by Richard Mlynarik long ago (c. 1993?) -- | |
| 29 added call-with-condition-handler; synch. up to released FSF 19.7 | |
| 30 for lemacs 19.8. some signal changes. | |
| 31 Various work by Ben Wing, 1995-1996: | |
| 32 added all stuff dealing with trapping errors, suspended-errors, etc. | |
| 33 added most Fsignal front ends. | |
| 34 added warning code. | |
| 35 reworked the Fsignal code and synched the rest up to FSF 19.30. | |
| 36 Some changes by Martin Buchholz c. 1999? | |
| 37 e.g. PRIMITIVE_FUNCALL macros. | |
| 38 New call_trapping_problems code and large comments below | |
| 39 by Ben Wing, Mar-Apr 2000. | |
| 40 */ | |
| 41 | |
| 42 /* This file has been Mule-ized. */ | |
| 43 | |
| 44 /* What is in this file? | |
| 45 | |
| 46 This file contains the engine for the ELisp interpreter in XEmacs. | |
| 47 The engine does the actual work of implementing function calls, | |
| 48 form evaluation, non-local exits (catch, throw, signal, | |
| 49 condition-case, call-with-condition-handler), unwind-protects, | |
| 50 dynamic bindings, let constructs, backtraces, etc. You might say | |
| 51 that this module is the very heart of XEmacs, and everything else | |
| 52 in XEmacs is merely an auxiliary module implementing some specific | |
| 53 functionality that may be called from the heart at an appropriate | |
| 54 time. | |
| 55 | |
| 56 The only exception is the alloc.c module, which implements the | |
| 57 framework upon which this module (eval.c) works. alloc.c works | |
| 58 with creating the actual Lisp objects themselves and garbage | |
| 1960 | 59 collecting them as necessary, presenting a nice, high-level |
| 853 | 60 interface for object creation, deletion, access, and modification. |
| 61 | |
| 62 The only other exception that could be cited is the event-handling | |
| 63 module in event-stream.c. From its perspective, it is also the | |
| 64 heart of XEmacs, and controls exactly what gets done at what time. | |
| 65 From its perspective, eval.c is merely one of the auxiliary modules | |
| 66 out there that can be invoked by event-stream.c. | |
| 67 | |
| 68 Although the event-stream-centric view is a convenient fiction that | |
| 69 makes sense particularly from the user's perspective and from the | |
| 70 perspective of time, the engine-centric view is actually closest to | |
| 71 the truth, because anywhere within the event-stream module, you are | |
| 72 still somewhere in a Lisp backtrace, and event-loops are begun by | |
| 73 functions such as `command-loop-1', a Lisp function. | |
| 74 | |
| 75 As the Lisp engine is doing its thing, it maintains the state of | |
| 1960 | 76 the engine primarily in five list-like items, which are: |
| 853 | 77 |
| 78 -- the backtrace list | |
| 79 -- the catchtag list | |
| 80 -- the condition-handler list | |
| 81 -- the specbind list | |
| 82 -- the GCPRO list. | |
| 83 | |
| 84 These are described in detail in the next comment. | |
| 85 | |
| 86 --ben | |
| 87 */ | |
| 88 | |
| 89 /* Note that there are five separate lists used to maintain state in | |
| 90 the evaluator. All of them conceptually are stacks (last-in, | |
| 91 first-out). All non-local exits happen ultimately through the | |
| 92 catch/throw mechanism, which uses one of the five lists (the | |
| 93 catchtag list) and records the current state of the others in each | |
| 94 frame of the list (some other information is recorded and restored | |
| 95 as well, such as the current eval depth), so that all the state of | |
| 96 the evaluator is restored properly when a non-local exit occurs. | |
| 97 (Note that the current state of the condition-handler list is not | |
| 98 recorded in the catchtag list. Instead, when a condition-case or | |
| 99 call-with-condition-handler is set up, it installs an | |
| 100 unwind-protect on the specbind list to restore the appropriate | |
| 101 setting for the condition-handler list. During the course of | |
| 102 handling the non-local exit, all entries on the specbind list that | |
| 103 are past the location stored in the catch frame are "unwound" | |
| 104 (i.e. variable bindings are restored and unwind-protects are | |
| 105 executed), so the condition-handler list gets reset properly. | |
| 106 | |
| 107 The five lists are | |
| 108 | |
| 109 1. The backtrace list, which is chained through `struct backtrace's | |
| 110 declared in the stack frames of various primitives, and keeps | |
| 111 track of all Lisp function call entries and exits. | |
| 112 2. The catchtag list, which is chained through `struct catchtag's | |
| 113 declared in the stack frames of internal_catch and condition_case_1, | |
| 114 and keeps track of information needed to reset the internal state | |
| 115 of the evaluator to the state that was current when the catch or | |
| 116 condition-case were established, in the event of a non-local exit. | |
| 117 3. The condition-handler list, which is a simple Lisp list with new | |
| 118 entries consed onto the front of the list. It records condition-cases | |
| 119 and call-with-condition-handlers established either from C or from | |
| 120 Lisp. Unlike with the other lists (but similar to everything else | |
| 121 of a similar nature in the rest of the C and Lisp code), it takes care | |
| 122 of restoring itself appropriately in the event of a non-local exit | |
| 123 through the use of the unwind-protect mechanism. | |
| 124 4. The specbind list, which is a contiguous array of `struct specbinding's, | |
| 125 expanded as necessary using realloc(). It holds dynamic variable | |
| 126 bindings (the only kind we currently have in ELisp) and unwind-protects. | |
| 127 5. The GCPRO list, which is chained through `struct gcpro's declared in | |
| 128 the stack frames of any functions that need to GC-protect Lisp_Objects | |
| 129 declared on the stack. This is one of the most fragile areas of the | |
| 130 entire scheme -- you must not forget to UNGCPRO at the end of your | |
| 131 function, you must make sure you GCPRO in many circumstances you don't | |
| 132 think you have to, etc. See the internals manual for more information | |
| 133 about this. | |
| 134 | |
| 135 --ben | |
| 136 */ | |
| 137 | |
| 428 | 138 #include <config.h> |
| 139 #include "lisp.h" | |
| 140 | |
| 141 #include "commands.h" | |
| 142 #include "backtrace.h" | |
| 143 #include "bytecode.h" | |
| 144 #include "buffer.h" | |
| 872 | 145 #include "console-impl.h" |
| 853 | 146 #include "device.h" |
| 147 #include "frame.h" | |
| 148 #include "lstream.h" | |
| 428 | 149 #include "opaque.h" |
| 1292 | 150 #include "profile.h" |
| 853 | 151 #include "window.h" |
| 428 | 152 |
| 153 struct backtrace *backtrace_list; | |
| 154 | |
| 155 /* Macros for calling subrs with an argument list whose length is only | |
| 156 known at runtime. See EXFUN and DEFUN for similar hackery. */ | |
| 157 | |
| 158 #define AV_0(av) | |
| 159 #define AV_1(av) av[0] | |
| 160 #define AV_2(av) AV_1(av), av[1] | |
| 161 #define AV_3(av) AV_2(av), av[2] | |
| 162 #define AV_4(av) AV_3(av), av[3] | |
| 163 #define AV_5(av) AV_4(av), av[4] | |
| 164 #define AV_6(av) AV_5(av), av[5] | |
| 165 #define AV_7(av) AV_6(av), av[6] | |
| 166 #define AV_8(av) AV_7(av), av[7] | |
| 167 | |
| 168 #define PRIMITIVE_FUNCALL_1(fn, av, ac) \ | |
| 444 | 169 (((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av))) |
| 428 | 170 |
| 171 /* If subrs take more than 8 arguments, more cases need to be added | |
| 172 to this switch. (But wait - don't do it - if you really need | |
| 173 a SUBR with more than 8 arguments, use max_args == MANY. | |
| 853 | 174 Or better, considering using a property list as one of your args. |
| 428 | 175 See the DEFUN macro in lisp.h) */ |
| 176 #define PRIMITIVE_FUNCALL(rv, fn, av, ac) do { \ | |
| 177 void (*PF_fn)(void) = (void (*)(void)) fn; \ | |
| 178 Lisp_Object *PF_av = (av); \ | |
| 179 switch (ac) \ | |
| 180 { \ | |
| 436 | 181 default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break; \ |
| 428 | 182 case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break; \ |
| 183 case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break; \ | |
| 184 case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break; \ | |
| 185 case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break; \ | |
| 186 case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break; \ | |
| 187 case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break; \ | |
| 188 case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break; \ | |
| 189 case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break; \ | |
| 190 } \ | |
| 191 } while (0) | |
| 192 | |
| 193 #define FUNCALL_SUBR(rv, subr, av, ac) \ | |
| 194 PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac); | |
| 195 | |
| 196 | |
| 197 /* This is the list of current catches (and also condition-cases). | |
| 853 | 198 This is a stack: the most recent catch is at the head of the list. |
| 199 The list is threaded through the stack frames of the C functions | |
| 200 that set up the catches; this is similar to the way the GCPRO list | |
| 201 is handled, but different from the condition-handler list (which is | |
| 202 a simple Lisp list) and the specbind stack, which is a contiguous | |
| 203 array of `struct specbinding's, grown (using realloc()) as | |
| 204 necessary. (Note that all four of these lists behave as a stacks.) | |
| 205 | |
| 3025 | 206 Catches are created by declaring a `struct catchtag' locally, |
| 853 | 207 filling the .TAG field in with the tag, and doing a setjmp() on |
| 208 .JMP. Fthrow() will store the value passed to it in .VAL and | |
| 209 longjmp() back to .JMP, back to the function that established the | |
| 210 catch. This will always be either internal_catch() (catches | |
| 211 established internally or through `catch') or condition_case_1 | |
| 212 (condition-cases established internally or through | |
| 213 `condition-case'). | |
| 428 | 214 |
| 215 The catchtag also records the current position in the | |
| 216 call stack (stored in BACKTRACE_LIST), the current position | |
| 217 in the specpdl stack (used for variable bindings and | |
| 218 unwind-protects), the value of LISP_EVAL_DEPTH, and the | |
| 219 current position in the GCPRO stack. All of these are | |
| 220 restored by Fthrow(). | |
| 853 | 221 */ |
| 428 | 222 |
| 223 struct catchtag *catchlist; | |
| 224 | |
| 853 | 225 /* A special tag that can be used internally from C code to catch |
| 226 every attempt to throw past this level. */ | |
| 227 Lisp_Object Vcatch_everything_tag; | |
| 228 | |
| 428 | 229 Lisp_Object Qautoload, Qmacro, Qexit; |
| 230 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues; | |
| 231 Lisp_Object Vquit_flag, Vinhibit_quit; | |
| 232 Lisp_Object Qand_rest, Qand_optional; | |
| 233 Lisp_Object Qdebug_on_error, Qstack_trace_on_error; | |
| 234 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal; | |
| 235 Lisp_Object Qdebugger; | |
| 236 Lisp_Object Qinhibit_quit; | |
| 887 | 237 Lisp_Object Qfinalize_list; |
| 428 | 238 Lisp_Object Qrun_hooks; |
| 239 Lisp_Object Qsetq; | |
| 240 Lisp_Object Qdisplay_warning; | |
| 241 Lisp_Object Vpending_warnings, Vpending_warnings_tail; | |
| 242 Lisp_Object Qif; | |
| 243 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
244 Lisp_Object Qthrow; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
245 Lisp_Object Qobsolete_throw; |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
246 Lisp_Object Qmultiple_value_list_internal; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
247 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
248 static int first_desired_multiple_value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
249 /* Used outside this file, somewhat uncleanly, in the IGNORE_MULTIPLE_VALUES |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
250 macro: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
251 int multiple_value_current_limit; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
252 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
253 Fixnum Vmultiple_values_limit; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
254 |
| 853 | 255 /* Flags specifying which operations are currently inhibited. */ |
| 256 int inhibit_flags; | |
| 257 | |
| 258 /* Buffers, frames, windows, devices, and consoles created since most | |
| 259 recent active | |
| 260 call_trapping_problems (INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION). | |
| 261 */ | |
| 262 Lisp_Object Vdeletable_permanent_display_objects; | |
| 263 | |
| 264 /* Buffers created since most recent active | |
| 265 call_trapping_problems (INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION). */ | |
| 266 Lisp_Object Vmodifiable_buffers; | |
| 793 | 267 |
| 268 /* Minimum level at which warnings are logged. Below this, they're ignored | |
| 269 entirely -- not even generated. */ | |
| 270 Lisp_Object Vlog_warning_minimum_level; | |
| 271 | |
| 428 | 272 /* Non-nil means record all fset's and provide's, to be undone |
| 273 if the file being autoloaded is not fully loaded. | |
| 274 They are recorded by being consed onto the front of Vautoload_queue: | |
| 275 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */ | |
| 276 Lisp_Object Vautoload_queue; | |
| 277 | |
| 278 /* Current number of specbindings allocated in specpdl. */ | |
| 279 int specpdl_size; | |
| 280 | |
| 281 /* Pointer to beginning of specpdl. */ | |
| 282 struct specbinding *specpdl; | |
| 283 | |
| 284 /* Pointer to first unused element in specpdl. */ | |
| 285 struct specbinding *specpdl_ptr; | |
| 286 | |
| 287 /* specpdl_ptr - specpdl */ | |
| 288 int specpdl_depth_counter; | |
| 289 | |
| 290 /* Maximum size allowed for specpdl allocation */ | |
| 458 | 291 Fixnum max_specpdl_size; |
| 428 | 292 |
| 293 /* Depth in Lisp evaluations and function calls. */ | |
| 1292 | 294 int lisp_eval_depth; |
| 428 | 295 |
| 296 /* Maximum allowed depth in Lisp evaluations and function calls. */ | |
| 458 | 297 Fixnum max_lisp_eval_depth; |
| 428 | 298 |
| 299 /* Nonzero means enter debugger before next function call */ | |
| 300 static int debug_on_next_call; | |
| 301 | |
| 1292 | 302 int backtrace_with_internal_sections; |
| 303 | |
| 428 | 304 /* List of conditions (non-nil atom means all) which cause a backtrace |
| 305 if an error is handled by the command loop's error handler. */ | |
| 306 Lisp_Object Vstack_trace_on_error; | |
| 307 | |
| 308 /* List of conditions (non-nil atom means all) which enter the debugger | |
| 309 if an error is handled by the command loop's error handler. */ | |
| 310 Lisp_Object Vdebug_on_error; | |
| 311 | |
| 312 /* List of conditions and regexps specifying error messages which | |
| 313 do not enter the debugger even if Vdebug_on_error says they should. */ | |
| 314 Lisp_Object Vdebug_ignored_errors; | |
| 315 | |
| 316 /* List of conditions (non-nil atom means all) which cause a backtrace | |
| 317 if any error is signalled. */ | |
| 318 Lisp_Object Vstack_trace_on_signal; | |
| 319 | |
| 320 /* List of conditions (non-nil atom means all) which enter the debugger | |
| 321 if any error is signalled. */ | |
| 322 Lisp_Object Vdebug_on_signal; | |
| 323 | |
| 324 /* Nonzero means enter debugger if a quit signal | |
| 325 is handled by the command loop's error handler. | |
| 326 | |
| 327 From lisp, this is a boolean variable and may have the values 0 and 1. | |
| 328 But, eval.c temporarily uses the second bit of this variable to indicate | |
| 329 that a critical_quit is in progress. The second bit is reset immediately | |
| 330 after it is processed in signal_call_debugger(). */ | |
| 331 int debug_on_quit; | |
| 332 | |
| 333 #if 0 /* FSFmacs */ | |
| 334 /* entering_debugger is basically equivalent */ | |
| 335 /* The value of num_nonmacro_input_chars as of the last time we | |
| 336 started to enter the debugger. If we decide to enter the debugger | |
| 337 again when this is still equal to num_nonmacro_input_chars, then we | |
| 338 know that the debugger itself has an error, and we should just | |
| 339 signal the error instead of entering an infinite loop of debugger | |
| 340 invocations. */ | |
| 341 int when_entered_debugger; | |
| 342 #endif | |
| 343 | |
| 344 /* Nonzero means we are trying to enter the debugger. | |
| 345 This is to prevent recursive attempts. | |
| 346 Cleared by the debugger calling Fbacktrace */ | |
| 347 static int entering_debugger; | |
| 348 | |
| 349 /* Function to call to invoke the debugger */ | |
| 350 Lisp_Object Vdebugger; | |
| 351 | |
| 853 | 352 /* List of condition handlers currently in effect. |
| 353 The elements of this lists were at one point in the past | |
| 354 threaded through the stack frames of Fcondition_case and | |
| 355 related functions, but now are stored separately in a normal | |
| 356 stack. When an error is signaled (by calling Fsignal, below), | |
| 357 this list is searched for an element that applies. | |
| 428 | 358 |
| 359 Each element of this list is one of the following: | |
| 360 | |
| 853 | 361 -- A list of a handler function and possibly args to pass to the |
| 362 function. This is a handler established with the Lisp primitive | |
| 363 `call-with-condition-handler' or related C function | |
| 364 call_with_condition_handler(): | |
| 365 | |
| 366 If the handler function is an opaque ptr object, it is a handler | |
| 367 that was established in C using call_with_condition_handler(), | |
| 368 and the contents of the object are a function pointer which takes | |
| 369 three arguments, the signal name and signal data (same arguments | |
| 370 passed to `signal') and a third Lisp_Object argument, specified | |
| 371 in the call to call_with_condition_handler() and stored as the | |
| 372 second element of the list containing the handler functionl. | |
| 373 | |
| 374 If the handler function is a regular Lisp_Object, it is a handler | |
| 375 that was established using `call-with-condition-handler'. | |
| 376 Currently there are no more arguments in the list containing the | |
| 377 handler function, and only one argument is passed to the handler | |
| 378 function: a cons of the signal name and signal data arguments | |
| 379 passed to `signal'. | |
| 380 | |
| 381 -- A list whose car is Qunbound and whose cdr is Qt. This is a | |
| 382 special condition-case handler established by C code with | |
| 383 condition_case_1(). All errors are trapped; the debugger is not | |
| 384 invoked even if `debug-on-error' was set. | |
| 385 | |
| 386 -- A list whose car is Qunbound and whose cdr is Qerror. This is a | |
| 387 special condition-case handler established by C code with | |
| 388 condition_case_1(). It is like Qt except that the debugger is | |
| 389 invoked normally if it is called for. | |
| 390 | |
| 391 -- A list whose car is Qunbound and whose cdr is a list of lists | |
| 392 (CONDITION-NAME BODY ...) exactly as in `condition-case'. This is | |
| 393 a normal `condition-case' handler. | |
| 394 | |
| 395 Note that in all cases *except* the first, there is a corresponding | |
| 396 catch, whose TAG is the value of Vcondition_handlers just after the | |
| 397 handler data just described is pushed onto it. The reason is that | |
| 398 `condition-case' handlers need to throw back to the place where the | |
| 399 handler was installed before invoking it, while | |
| 400 `call-with-condition-handler' handlers are invoked in the | |
| 401 environment that `signal' was invoked in. */ | |
| 402 | |
| 403 | |
| 428 | 404 static Lisp_Object Vcondition_handlers; |
| 405 | |
| 853 | 406 /* I think we should keep this enabled all the time, not just when |
| 407 error checking is enabled, because if one of these puppies pops up, | |
| 408 it will trash the stack if not caught, making it that much harder to | |
| 409 debug. It doesn't cause speed loss. */ | |
| 442 | 410 #define DEFEND_AGAINST_THROW_RECURSION |
| 411 | |
| 412 #ifdef DEFEND_AGAINST_THROW_RECURSION | |
| 428 | 413 /* Used for error catching purposes by throw_or_bomb_out */ |
| 414 static int throw_level; | |
| 442 | 415 #endif |
| 416 | |
| 1123 | 417 static int warning_will_be_discarded (Lisp_Object level); |
| 2532 | 418 static Lisp_Object maybe_get_trapping_problems_backtrace (void); |
| 1123 | 419 |
| 428 | 420 |
|
5084
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
421 |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
422 /* When parsing keyword arguments; is some element of NARGS |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
423 :allow-other-keys, and is that element followed by a non-nil Lisp |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
424 object? */ |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
425 |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
426 Boolint |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
427 non_nil_allow_other_keys_p (Elemcount offset, int nargs, Lisp_Object *args) |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
428 { |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
429 Lisp_Object key, value; |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
430 while (offset + 1 < nargs) |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
431 { |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
432 key = args[offset++]; |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
433 value = args[offset++]; |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
434 if (EQ (key, Q_allow_other_keys)) |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
435 { |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
436 /* The ANSI Common Lisp standard says the first value for a given |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
437 keyword overrides. */ |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
438 return !NILP (value); |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
439 } |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
440 } |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
441 return 0; |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
442 } |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
443 |
| 428 | 444 /************************************************************************/ |
| 445 /* The subr object type */ | |
| 446 /************************************************************************/ | |
| 447 | |
| 448 static void | |
| 2286 | 449 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int UNUSED (escapeflag)) |
| 428 | 450 { |
| 451 Lisp_Subr *subr = XSUBR (obj); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
452 const Ascbyte *header = |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
453 (subr->max_args == UNEVALLED) ? "#<special-operator " : "#<subr "; |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
454 const Ascbyte *name = subr_name (subr); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
455 const Ascbyte *trailer = subr->prompt ? " (interactive)>" : ">"; |
| 428 | 456 |
| 457 if (print_readably) | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
458 printing_unreadable_object_fmt ("%s%s%s", header, name, trailer); |
| 428 | 459 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
460 write_ascstring (printcharfun, header); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
461 write_ascstring (printcharfun, name); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
462 write_ascstring (printcharfun, trailer); |
| 428 | 463 } |
| 464 | |
| 1204 | 465 static const struct memory_description subr_description[] = { |
| 2551 | 466 { XD_DOC_STRING, offsetof (Lisp_Subr, doc), 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 428 | 467 { XD_END } |
| 468 }; | |
| 469 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
470 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("subr", subr, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
471 0, print_subr, 0, 0, 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
472 subr_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
473 Lisp_Subr); |
| 428 | 474 |
| 475 /************************************************************************/ | |
| 476 /* Entering the debugger */ | |
| 477 /************************************************************************/ | |
| 478 | |
| 853 | 479 static Lisp_Object |
| 480 current_warning_level (void) | |
| 481 { | |
| 482 if (inhibit_flags & ISSUE_WARNINGS_AT_DEBUG_LEVEL) | |
| 483 return Qdebug; | |
| 484 else | |
| 485 return Qwarning; | |
| 486 } | |
| 487 | |
| 428 | 488 /* Actually call the debugger. ARG is a list of args that will be |
| 489 passed to the debugger function, as follows; | |
| 490 | |
| 491 If due to frame exit, args are `exit' and the value being returned; | |
| 492 this function's value will be returned instead of that. | |
| 493 If due to error, args are `error' and a list of the args to `signal'. | |
| 494 If due to `apply' or `funcall' entry, one arg, `lambda'. | |
| 495 If due to `eval' entry, one arg, t. | |
| 496 | |
| 497 */ | |
| 498 | |
| 499 static Lisp_Object | |
| 500 call_debugger_259 (Lisp_Object arg) | |
| 501 { | |
| 502 return apply1 (Vdebugger, arg); | |
| 503 } | |
| 504 | |
| 505 /* Call the debugger, doing some encapsulation. We make sure we have | |
| 506 some room on the eval and specpdl stacks, and bind entering_debugger | |
| 507 to 1 during this call. This is used to trap errors that may occur | |
| 508 when entering the debugger (e.g. the value of `debugger' is invalid), | |
| 509 so that the debugger will not be recursively entered if debug-on-error | |
| 510 is set. (Otherwise, XEmacs would infinitely recurse, attempting to | |
| 511 enter the debugger.) entering_debugger gets reset to 0 as soon | |
| 512 as a backtrace is displayed, so that further errors can indeed be | |
| 513 handled normally. | |
| 514 | |
| 3025 | 515 We also establish a catch for `debugger'. If the debugger function |
| 428 | 516 throws to this instead of returning a value, it means that the user |
| 517 pressed 'c' (pretend like the debugger was never entered). The | |
| 518 function then returns Qunbound. (If the user pressed 'r', for | |
| 519 return a value, then the debugger function returns normally with | |
| 520 this value.) | |
| 521 | |
| 522 The difference between 'c' and 'r' is as follows: | |
| 523 | |
| 524 debug-on-call: | |
| 525 No difference. The call proceeds as normal. | |
| 526 debug-on-exit: | |
| 527 With 'r', the specified value is returned as the function's | |
| 528 return value. With 'c', the value that would normally be | |
| 529 returned is returned. | |
| 530 signal: | |
| 531 With 'r', the specified value is returned as the return | |
| 532 value of `signal'. (This is the only time that `signal' | |
| 533 can return, instead of making a non-local exit.) With `c', | |
| 534 `signal' will continue looking for handlers as if the | |
| 535 debugger was never entered, and will probably end up | |
| 536 throwing to a handler or to top-level. | |
| 537 */ | |
| 538 | |
| 539 static Lisp_Object | |
| 540 call_debugger (Lisp_Object arg) | |
| 541 { | |
| 542 int threw; | |
| 543 Lisp_Object val; | |
| 544 int speccount; | |
| 545 | |
| 853 | 546 debug_on_next_call = 0; |
| 547 | |
| 548 if (inhibit_flags & INHIBIT_ENTERING_DEBUGGER) | |
| 549 { | |
| 550 if (!(inhibit_flags & INHIBIT_WARNING_ISSUE)) | |
| 551 warn_when_safe | |
| 552 (Qdebugger, current_warning_level (), | |
| 553 "Unable to enter debugger within critical section"); | |
| 554 return Qunbound; | |
| 555 } | |
| 556 | |
| 428 | 557 if (lisp_eval_depth + 20 > max_lisp_eval_depth) |
| 558 max_lisp_eval_depth = lisp_eval_depth + 20; | |
| 559 if (specpdl_size + 40 > max_specpdl_size) | |
| 560 max_specpdl_size = specpdl_size + 40; | |
| 853 | 561 |
| 562 speccount = internal_bind_int (&entering_debugger, 1); | |
| 2532 | 563 val = internal_catch (Qdebugger, call_debugger_259, arg, &threw, 0, 0); |
| 428 | 564 |
| 771 | 565 return unbind_to_1 (speccount, ((threw) |
| 428 | 566 ? Qunbound /* Not returning a value */ |
| 567 : val)); | |
| 568 } | |
| 569 | |
| 570 /* Called when debug-on-exit behavior is called for. Enter the debugger | |
| 571 with the appropriate args for this. VAL is the exit value that is | |
| 572 about to be returned. */ | |
| 573 | |
| 574 static Lisp_Object | |
| 575 do_debug_on_exit (Lisp_Object val) | |
| 576 { | |
| 577 /* This is falsified by call_debugger */ | |
| 578 Lisp_Object v = call_debugger (list2 (Qexit, val)); | |
| 579 | |
| 580 return !UNBOUNDP (v) ? v : val; | |
| 581 } | |
| 582 | |
| 583 /* Called when debug-on-call behavior is called for. Enter the debugger | |
| 584 with the appropriate args for this. VAL is either t for a call | |
| 3025 | 585 through `eval' or `lambda' for a call through `funcall'. |
| 428 | 586 |
| 587 #### The differentiation here between EVAL and FUNCALL is bogus. | |
| 588 FUNCALL can be defined as | |
| 589 | |
| 590 (defmacro func (fun &rest args) | |
| 591 (cons (eval fun) args)) | |
| 592 | |
| 593 and should be treated as such. | |
| 594 */ | |
| 595 | |
| 596 static void | |
| 597 do_debug_on_call (Lisp_Object code) | |
| 598 { | |
| 599 debug_on_next_call = 0; | |
| 600 backtrace_list->debug_on_exit = 1; | |
| 601 call_debugger (list1 (code)); | |
| 602 } | |
| 603 | |
| 604 /* LIST is the value of one of the variables `debug-on-error', | |
| 605 `debug-on-signal', `stack-trace-on-error', or `stack-trace-on-signal', | |
| 606 and CONDITIONS is the list of error conditions associated with | |
| 607 the error being signalled. This returns non-nil if LIST | |
| 608 matches CONDITIONS. (A nil value for LIST does not match | |
| 609 CONDITIONS. A non-list value for LIST does match CONDITIONS. | |
| 610 A list matches CONDITIONS when one of the symbols in LIST is the | |
| 611 same as one of the symbols in CONDITIONS.) */ | |
| 612 | |
| 613 static int | |
| 614 wants_debugger (Lisp_Object list, Lisp_Object conditions) | |
| 615 { | |
| 616 if (NILP (list)) | |
| 617 return 0; | |
| 618 if (! CONSP (list)) | |
| 619 return 1; | |
| 620 | |
| 621 while (CONSP (conditions)) | |
| 622 { | |
| 2552 | 623 Lisp_Object curr, tail; |
| 624 curr = XCAR (conditions); | |
| 428 | 625 for (tail = list; CONSP (tail); tail = XCDR (tail)) |
| 2552 | 626 if (EQ (XCAR (tail), curr)) |
| 428 | 627 return 1; |
| 628 conditions = XCDR (conditions); | |
| 629 } | |
| 630 return 0; | |
| 631 } | |
| 632 | |
| 633 | |
| 634 /* Return 1 if an error with condition-symbols CONDITIONS, | |
| 635 and described by SIGNAL-DATA, should skip the debugger | |
|
4624
9dd42cb187ed
Fix typo in comment on skip_debugger.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4535
diff
changeset
|
636 according to debug-ignored-errors. */ |
| 428 | 637 |
| 638 static int | |
| 639 skip_debugger (Lisp_Object conditions, Lisp_Object data) | |
| 640 { | |
| 641 /* This function can GC */ | |
| 642 Lisp_Object tail; | |
| 643 int first_string = 1; | |
| 644 Lisp_Object error_message = Qnil; | |
| 645 | |
| 646 for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail)) | |
| 647 { | |
| 648 if (STRINGP (XCAR (tail))) | |
| 649 { | |
| 650 if (first_string) | |
| 651 { | |
| 652 error_message = Ferror_message_string (data); | |
| 653 first_string = 0; | |
| 654 } | |
| 655 if (fast_lisp_string_match (XCAR (tail), error_message) >= 0) | |
| 656 return 1; | |
| 657 } | |
| 658 else | |
| 659 { | |
| 660 Lisp_Object contail; | |
| 661 | |
| 662 for (contail = conditions; CONSP (contail); contail = XCDR (contail)) | |
| 663 if (EQ (XCAR (tail), XCAR (contail))) | |
| 664 return 1; | |
| 665 } | |
| 666 } | |
| 667 | |
| 668 return 0; | |
| 669 } | |
| 670 | |
| 671 /* Actually generate a backtrace on STREAM. */ | |
| 672 | |
| 673 static Lisp_Object | |
| 674 backtrace_259 (Lisp_Object stream) | |
| 675 { | |
| 676 return Fbacktrace (stream, Qt); | |
| 677 } | |
| 678 | |
| 1130 | 679 #ifdef DEBUG_XEMACS |
| 680 | |
| 681 static void | |
| 682 trace_out_and_die (Lisp_Object err) | |
| 683 { | |
| 684 Fdisplay_error (err, Qt); | |
| 685 backtrace_259 (Qnil); | |
| 686 stderr_out ("XEmacs exiting to debugger.\n"); | |
| 687 Fforce_debugging_signal (Qt); | |
| 688 /* Unlikely to be reached */ | |
| 689 } | |
| 690 | |
| 691 #endif | |
| 692 | |
| 428 | 693 /* An error was signaled. Maybe call the debugger, if the `debug-on-error' |
| 694 etc. variables call for this. CONDITIONS is the list of conditions | |
| 695 associated with the error being signalled. SIG is the actual error | |
| 696 being signalled, and DATA is the associated data (these are exactly | |
| 697 the same as the arguments to `signal'). ACTIVE_HANDLERS is the | |
| 698 list of error handlers that are to be put in place while the debugger | |
| 699 is called. This is generally the remaining handlers that are | |
| 700 outside of the innermost handler trapping this error. This way, | |
| 701 if the same error occurs inside of the debugger, you usually don't get | |
| 702 the debugger entered recursively. | |
| 703 | |
| 704 This function returns Qunbound if it didn't call the debugger or if | |
| 705 the user asked (through 'c') that XEmacs should pretend like the | |
| 706 debugger was never entered. Otherwise, it returns the value | |
| 707 that the user specified with `r'. (Note that much of the time, | |
| 708 the user will abort with C-], and we will never have a chance to | |
| 709 return anything at all.) | |
| 710 | |
| 711 SIGNAL_VARS_ONLY means we should only look at debug-on-signal | |
| 712 and stack-trace-on-signal to control whether we do anything. | |
| 713 This is so that debug-on-error doesn't make handled errors | |
| 714 cause the debugger to get invoked. | |
| 715 | |
| 716 STACK_TRACE_DISPLAYED and DEBUGGER_ENTERED are used so that | |
| 717 those functions aren't done more than once in a single `signal' | |
| 718 session. */ | |
| 719 | |
| 720 static Lisp_Object | |
| 721 signal_call_debugger (Lisp_Object conditions, | |
| 722 Lisp_Object sig, Lisp_Object data, | |
| 723 Lisp_Object active_handlers, | |
| 724 int signal_vars_only, | |
| 725 int *stack_trace_displayed, | |
| 726 int *debugger_entered) | |
| 727 { | |
| 853 | 728 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE |
| 428 | 729 /* This function can GC */ |
| 853 | 730 #else /* reality check */ |
| 731 /* This function cannot GC because it inhibits GC during its operation */ | |
| 732 #endif | |
| 733 | |
| 428 | 734 Lisp_Object val = Qunbound; |
| 735 Lisp_Object all_handlers = Vcondition_handlers; | |
| 736 Lisp_Object temp_data = Qnil; | |
| 853 | 737 int outer_speccount = specpdl_depth(); |
| 738 int speccount; | |
| 739 | |
| 740 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE | |
| 428 | 741 struct gcpro gcpro1, gcpro2; |
| 742 GCPRO2 (all_handlers, temp_data); | |
| 853 | 743 #else |
| 744 begin_gc_forbidden (); | |
| 745 #endif | |
| 746 | |
| 747 speccount = specpdl_depth(); | |
| 428 | 748 |
| 749 Vcondition_handlers = active_handlers; | |
| 750 | |
| 751 temp_data = Fcons (sig, data); /* needed for skip_debugger */ | |
| 752 | |
| 753 if (!entering_debugger && !*stack_trace_displayed && !signal_vars_only | |
| 754 && wants_debugger (Vstack_trace_on_error, conditions) | |
| 755 && !skip_debugger (conditions, temp_data)) | |
| 756 { | |
| 757 specbind (Qdebug_on_error, Qnil); | |
| 758 specbind (Qstack_trace_on_error, Qnil); | |
| 759 specbind (Qdebug_on_signal, Qnil); | |
| 760 specbind (Qstack_trace_on_signal, Qnil); | |
| 761 | |
| 442 | 762 if (!noninteractive) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
763 internal_with_output_to_temp_buffer (build_ascstring ("*Backtrace*"), |
| 442 | 764 backtrace_259, |
| 765 Qnil, | |
| 766 Qnil); | |
| 767 else /* in batch mode, we want this going to stderr. */ | |
| 768 backtrace_259 (Qnil); | |
| 771 | 769 unbind_to (speccount); |
| 428 | 770 *stack_trace_displayed = 1; |
| 771 } | |
| 772 | |
| 773 if (!entering_debugger && !*debugger_entered && !signal_vars_only | |
| 774 && (EQ (sig, Qquit) | |
| 775 ? debug_on_quit | |
| 776 : wants_debugger (Vdebug_on_error, conditions)) | |
| 777 && !skip_debugger (conditions, temp_data)) | |
| 778 { | |
| 779 debug_on_quit &= ~2; /* reset critical bit */ | |
| 1123 | 780 |
| 428 | 781 specbind (Qdebug_on_error, Qnil); |
| 782 specbind (Qstack_trace_on_error, Qnil); | |
| 783 specbind (Qdebug_on_signal, Qnil); | |
| 784 specbind (Qstack_trace_on_signal, Qnil); | |
| 785 | |
| 1130 | 786 #ifdef DEBUG_XEMACS |
| 787 if (noninteractive) | |
| 788 trace_out_and_die (Fcons (sig, data)); | |
| 789 #endif | |
| 790 | |
| 428 | 791 val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); |
| 853 | 792 unbind_to (speccount); |
| 428 | 793 *debugger_entered = 1; |
| 794 } | |
| 795 | |
| 796 if (!entering_debugger && !*stack_trace_displayed | |
| 797 && wants_debugger (Vstack_trace_on_signal, conditions)) | |
| 798 { | |
| 799 specbind (Qdebug_on_error, Qnil); | |
| 800 specbind (Qstack_trace_on_error, Qnil); | |
| 801 specbind (Qdebug_on_signal, Qnil); | |
| 802 specbind (Qstack_trace_on_signal, Qnil); | |
| 803 | |
| 442 | 804 if (!noninteractive) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
805 internal_with_output_to_temp_buffer (build_ascstring ("*Backtrace*"), |
| 442 | 806 backtrace_259, |
| 807 Qnil, | |
| 808 Qnil); | |
| 809 else /* in batch mode, we want this going to stderr. */ | |
| 810 backtrace_259 (Qnil); | |
| 771 | 811 unbind_to (speccount); |
| 428 | 812 *stack_trace_displayed = 1; |
| 813 } | |
| 814 | |
| 815 if (!entering_debugger && !*debugger_entered | |
| 816 && (EQ (sig, Qquit) | |
| 817 ? debug_on_quit | |
| 818 : wants_debugger (Vdebug_on_signal, conditions))) | |
| 819 { | |
| 820 debug_on_quit &= ~2; /* reset critical bit */ | |
| 1123 | 821 |
| 428 | 822 specbind (Qdebug_on_error, Qnil); |
| 823 specbind (Qstack_trace_on_error, Qnil); | |
| 824 specbind (Qdebug_on_signal, Qnil); | |
| 825 specbind (Qstack_trace_on_signal, Qnil); | |
| 826 | |
| 1130 | 827 #ifdef DEBUG_XEMACS |
| 828 if (noninteractive) | |
| 829 trace_out_and_die (Fcons (sig, data)); | |
| 830 #endif | |
| 831 | |
| 428 | 832 val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); |
| 833 *debugger_entered = 1; | |
| 834 } | |
| 835 | |
| 853 | 836 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE |
| 428 | 837 UNGCPRO; |
| 853 | 838 #endif |
| 428 | 839 Vcondition_handlers = all_handlers; |
| 853 | 840 return unbind_to_1 (outer_speccount, val); |
| 428 | 841 } |
| 842 | |
| 843 | |
| 844 /************************************************************************/ | |
| 845 /* The basic special forms */ | |
| 846 /************************************************************************/ | |
| 847 | |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
848 /* Except for Fprogn(), the basic special operators below are only called |
| 428 | 849 from interpreted code. The byte compiler turns them into bytecodes. */ |
| 850 | |
| 851 DEFUN ("or", For, 0, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
852 Eval ARGS until one of them yields non-nil, then return that value. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
853 The remaining ARGS are not evalled at all. |
| 428 | 854 If all args return nil, return nil. |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
855 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
856 Any multiple values from the last form, and only from the last form, are |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
857 passed back. See `values' and `multiple-value-bind'. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
858 |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
859 arguments: (&rest ARGS) |
| 428 | 860 */ |
| 861 (args)) | |
| 862 { | |
| 863 /* This function can GC */ | |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
864 Lisp_Object val = Qnil; |
| 428 | 865 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
866 LIST_LOOP_3 (arg, args, tail) |
| 428 | 867 { |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
868 if (!NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
869 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
870 if (NILP (XCDR (tail))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
871 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
872 /* Pass back multiple values if this is the last one: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
873 return val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
874 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
875 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
876 return IGNORE_MULTIPLE_VALUES (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
877 } |
| 428 | 878 } |
| 879 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
880 return val; |
| 428 | 881 } |
| 882 | |
| 883 DEFUN ("and", Fand, 0, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
884 Eval ARGS until one of them yields nil, then return nil. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
885 The remaining ARGS are not evalled at all. |
| 428 | 886 If no arg yields nil, return the last arg's value. |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
887 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
888 Any multiple values from the last form, and only from the last form, are |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
889 passed back. See `values' and `multiple-value-bind'. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
890 |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
891 arguments: (&rest ARGS) |
| 428 | 892 */ |
| 893 (args)) | |
| 894 { | |
| 895 /* This function can GC */ | |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
896 Lisp_Object val = Qt; |
| 428 | 897 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
898 LIST_LOOP_3 (arg, args, tail) |
| 428 | 899 { |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
900 if (NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
901 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
902 if (NILP (XCDR (tail))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
903 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
904 /* Pass back any multiple values for the last form: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
905 return val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
906 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
907 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
908 return Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
909 } |
| 428 | 910 } |
| 911 | |
| 912 return val; | |
| 913 } | |
| 914 | |
| 915 DEFUN ("if", Fif, 2, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
916 If COND yields non-nil, do THEN, else do ELSE. |
| 428 | 917 Returns the value of THEN or the value of the last of the ELSE's. |
| 918 THEN must be one expression, but ELSE... can be zero or more expressions. | |
| 919 If COND yields nil, and there are no ELSE's, the value is nil. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
920 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
921 arguments: (COND THEN &rest ELSE) |
| 428 | 922 */ |
| 923 (args)) | |
| 924 { | |
| 925 /* This function can GC */ | |
| 926 Lisp_Object condition = XCAR (args); | |
| 927 Lisp_Object then_form = XCAR (XCDR (args)); | |
| 928 Lisp_Object else_forms = XCDR (XCDR (args)); | |
| 929 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
930 if (!NILP (IGNORE_MULTIPLE_VALUES (Feval (condition)))) |
| 428 | 931 return Feval (then_form); |
| 932 else | |
| 933 return Fprogn (else_forms); | |
| 934 } | |
| 935 | |
| 936 /* Macros `when' and `unless' are trivially defined in Lisp, | |
| 937 but it helps for bootstrapping to have them ALWAYS defined. */ | |
| 938 | |
| 939 DEFUN ("when", Fwhen, 1, MANY, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
940 If COND yields non-nil, do BODY, else return nil. |
| 428 | 941 BODY can be zero or more expressions. If BODY is nil, return nil. |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
942 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
943 arguments: (COND &rest BODY) |
| 428 | 944 */ |
| 945 (int nargs, Lisp_Object *args)) | |
| 946 { | |
| 947 Lisp_Object cond = args[0]; | |
| 948 Lisp_Object body; | |
| 853 | 949 |
| 428 | 950 switch (nargs) |
| 951 { | |
| 952 case 1: body = Qnil; break; | |
| 953 case 2: body = args[1]; break; | |
| 954 default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break; | |
| 955 } | |
| 956 | |
| 957 return list3 (Qif, cond, body); | |
| 958 } | |
| 959 | |
| 960 DEFUN ("unless", Funless, 1, MANY, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
961 If COND yields nil, do BODY, else return nil. |
| 428 | 962 BODY can be zero or more expressions. If BODY is nil, return nil. |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
963 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
964 arguments: (COND &rest BODY) |
| 428 | 965 */ |
| 966 (int nargs, Lisp_Object *args)) | |
| 967 { | |
| 968 Lisp_Object cond = args[0]; | |
| 969 Lisp_Object body = Flist (nargs-1, args+1); | |
| 970 return Fcons (Qif, Fcons (cond, Fcons (Qnil, body))); | |
| 971 } | |
| 972 | |
| 973 DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
974 Try each clause until one succeeds. |
| 428 | 975 Each clause looks like (CONDITION BODY...). CONDITION is evaluated |
| 976 and, if the value is non-nil, this clause succeeds: | |
| 977 then the expressions in BODY are evaluated and the last one's | |
| 978 value is the value of the cond-form. | |
| 979 If no clause succeeds, cond returns nil. | |
| 980 If a clause has one element, as in (CONDITION), | |
| 981 CONDITION's value if non-nil is returned from the cond-form. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
982 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
983 arguments: (&rest CLAUSES) |
| 428 | 984 */ |
| 985 (args)) | |
| 986 { | |
| 987 /* This function can GC */ | |
| 442 | 988 REGISTER Lisp_Object val; |
| 428 | 989 |
| 990 LIST_LOOP_2 (clause, args) | |
| 991 { | |
| 992 CHECK_CONS (clause); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
993 if (!NILP (val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (clause))))) |
| 428 | 994 { |
| 995 if (!NILP (clause = XCDR (clause))) | |
| 996 { | |
| 997 CHECK_TRUE_LIST (clause); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
998 /* Pass back any multiple values here: */ |
| 428 | 999 val = Fprogn (clause); |
| 1000 } | |
| 1001 return val; | |
| 1002 } | |
| 1003 } | |
| 1004 | |
| 1005 return Qnil; | |
| 1006 } | |
| 1007 | |
| 1008 DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1009 Eval BODY forms sequentially and return value of last one. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1010 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1011 arguments: (&rest BODY) |
| 428 | 1012 */ |
| 1013 (args)) | |
| 1014 { | |
| 1015 /* This function can GC */ | |
| 1016 /* Caller must provide a true list in ARGS */ | |
| 442 | 1017 REGISTER Lisp_Object val = Qnil; |
| 428 | 1018 struct gcpro gcpro1; |
| 1019 | |
| 1020 GCPRO1 (args); | |
| 1021 | |
| 1022 { | |
| 1023 LIST_LOOP_2 (form, args) | |
| 1024 val = Feval (form); | |
| 1025 } | |
| 1026 | |
| 1027 UNGCPRO; | |
| 1028 return val; | |
| 1029 } | |
| 1030 | |
| 1031 /* Fprog1() is the canonical example of a function that must GCPRO a | |
| 1032 Lisp_Object across calls to Feval(). */ | |
| 1033 | |
| 1034 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /* | |
| 1035 Similar to `progn', but the value of the first form is returned. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1036 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1037 All the arguments are evaluated sequentially. The value of FIRST is saved |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1038 during evaluation of the remaining args, whose values are discarded. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1039 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1040 arguments: (FIRST &rest BODY) |
| 428 | 1041 */ |
| 1042 (args)) | |
| 1043 { | |
| 1849 | 1044 Lisp_Object val; |
| 428 | 1045 struct gcpro gcpro1; |
| 1046 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1047 val = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args))); |
| 428 | 1048 |
| 1049 GCPRO1 (val); | |
| 1050 | |
| 1051 { | |
| 1052 LIST_LOOP_2 (form, XCDR (args)) | |
| 1053 Feval (form); | |
| 1054 } | |
| 1055 | |
| 1056 UNGCPRO; | |
| 1057 return val; | |
| 1058 } | |
| 1059 | |
| 1060 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /* | |
| 1061 Similar to `progn', but the value of the second form is returned. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1062 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1063 All the arguments are evaluated sequentially. The value of SECOND is saved |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1064 during evaluation of the remaining args, whose values are discarded. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1065 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1066 arguments: (FIRST SECOND &rest BODY) |
| 428 | 1067 */ |
| 1068 (args)) | |
| 1069 { | |
| 1070 /* This function can GC */ | |
| 1849 | 1071 Lisp_Object val; |
| 428 | 1072 struct gcpro gcpro1; |
| 1073 | |
| 1074 Feval (XCAR (args)); | |
| 1075 args = XCDR (args); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1076 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1077 val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1078 |
| 428 | 1079 args = XCDR (args); |
| 1080 | |
| 1081 GCPRO1 (val); | |
| 1082 | |
| 442 | 1083 { |
| 1084 LIST_LOOP_2 (form, args) | |
| 1085 Feval (form); | |
| 1086 } | |
| 428 | 1087 |
| 1088 UNGCPRO; | |
| 1089 return val; | |
| 1090 } | |
| 1091 | |
| 1092 DEFUN ("let*", FletX, 1, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1093 Bind variables according to VARLIST then eval BODY. |
| 428 | 1094 The value of the last form in BODY is returned. |
| 1095 Each element of VARLIST is a symbol (which is bound to nil) | |
| 1096 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). | |
| 1097 Each VALUEFORM can refer to the symbols already bound by this VARLIST. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1098 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1099 arguments: (VARLIST &rest BODY) |
| 428 | 1100 */ |
| 1101 (args)) | |
| 1102 { | |
| 1103 /* This function can GC */ | |
| 1104 Lisp_Object varlist = XCAR (args); | |
| 1105 Lisp_Object body = XCDR (args); | |
| 1106 int speccount = specpdl_depth(); | |
| 1107 | |
| 1108 EXTERNAL_LIST_LOOP_3 (var, varlist, tail) | |
| 1109 { | |
| 1110 Lisp_Object symbol, value, tem; | |
| 1111 if (SYMBOLP (var)) | |
| 1112 symbol = var, value = Qnil; | |
| 1113 else | |
| 1114 { | |
| 1115 CHECK_CONS (var); | |
| 1116 symbol = XCAR (var); | |
| 1117 tem = XCDR (var); | |
| 1118 if (NILP (tem)) | |
| 1119 value = Qnil; | |
| 1120 else | |
| 1121 { | |
| 1122 CHECK_CONS (tem); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1123 value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); |
| 428 | 1124 if (!NILP (XCDR (tem))) |
| 563 | 1125 sferror |
| 428 | 1126 ("`let' bindings can have only one value-form", var); |
| 1127 } | |
| 1128 } | |
| 1129 specbind (symbol, value); | |
| 1130 } | |
| 771 | 1131 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 1132 } |
| 1133 | |
| 1134 DEFUN ("let", Flet, 1, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1135 Bind variables according to VARLIST then eval BODY. |
| 428 | 1136 The value of the last form in BODY is returned. |
| 1137 Each element of VARLIST is a symbol (which is bound to nil) | |
| 1138 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). | |
| 1139 All the VALUEFORMs are evalled before any symbols are bound. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1140 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1141 arguments: (VARLIST &rest BODY) |
| 428 | 1142 */ |
| 1143 (args)) | |
| 1144 { | |
| 1145 /* This function can GC */ | |
| 1146 Lisp_Object varlist = XCAR (args); | |
| 1147 Lisp_Object body = XCDR (args); | |
| 1148 int speccount = specpdl_depth(); | |
| 1149 Lisp_Object *temps; | |
| 1150 int idx; | |
| 1151 struct gcpro gcpro1; | |
| 1152 | |
| 1153 /* Make space to hold the values to give the bound variables. */ | |
| 1154 { | |
| 1155 int varcount; | |
| 1156 GET_EXTERNAL_LIST_LENGTH (varlist, varcount); | |
| 1157 temps = alloca_array (Lisp_Object, varcount); | |
| 1158 } | |
| 1159 | |
| 1160 /* Compute the values and store them in `temps' */ | |
| 1161 GCPRO1 (*temps); | |
| 1162 gcpro1.nvars = 0; | |
| 1163 | |
| 1164 idx = 0; | |
| 442 | 1165 { |
| 1166 LIST_LOOP_2 (var, varlist) | |
| 1167 { | |
| 1168 Lisp_Object *value = &temps[idx++]; | |
| 1169 if (SYMBOLP (var)) | |
| 1170 *value = Qnil; | |
| 1171 else | |
| 1172 { | |
| 1173 Lisp_Object tem; | |
| 1174 CHECK_CONS (var); | |
| 1175 tem = XCDR (var); | |
| 1176 if (NILP (tem)) | |
| 1177 *value = Qnil; | |
| 1178 else | |
| 1179 { | |
| 1180 CHECK_CONS (tem); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1181 *value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); |
| 442 | 1182 gcpro1.nvars = idx; |
| 1183 | |
| 1184 if (!NILP (XCDR (tem))) | |
| 563 | 1185 sferror |
| 442 | 1186 ("`let' bindings can have only one value-form", var); |
| 1187 } | |
| 1188 } | |
| 1189 } | |
| 1190 } | |
| 428 | 1191 |
| 1192 idx = 0; | |
| 442 | 1193 { |
| 1194 LIST_LOOP_2 (var, varlist) | |
| 1195 { | |
| 1196 specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]); | |
| 1197 } | |
| 1198 } | |
| 428 | 1199 |
| 1200 UNGCPRO; | |
| 1201 | |
| 771 | 1202 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 1203 } |
| 1204 | |
| 1205 DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1206 If TEST yields non-nil, eval BODY... and repeat. |
| 428 | 1207 The order of execution is thus TEST, BODY, TEST, BODY and so on |
| 1208 until TEST returns nil. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1209 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1210 arguments: (TEST &rest BODY) |
| 428 | 1211 */ |
| 1212 (args)) | |
| 1213 { | |
| 1214 /* This function can GC */ | |
| 1215 Lisp_Object test = XCAR (args); | |
| 1216 Lisp_Object body = XCDR (args); | |
| 1217 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1218 while (!NILP (IGNORE_MULTIPLE_VALUES (Feval (test)))) |
| 428 | 1219 { |
| 1220 QUIT; | |
| 1221 Fprogn (body); | |
| 1222 } | |
| 1223 | |
| 1224 return Qnil; | |
| 1225 } | |
| 1226 | |
| 1227 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /* | |
| 1228 \(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL. | |
| 1229 The symbols SYM are variables; they are literal (not evaluated). | |
| 1230 The values VAL are expressions; they are evaluated. | |
| 1231 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'. | |
| 1232 The second VAL is not computed until after the first SYM is set, and so on; | |
| 1233 each VAL can use the new value of variables set earlier in the `setq'. | |
| 1234 The return value of the `setq' form is the value of the last VAL. | |
| 1235 */ | |
| 1236 (args)) | |
| 1237 { | |
| 1238 /* This function can GC */ | |
| 1239 int nargs; | |
| 2421 | 1240 Lisp_Object retval = Qnil; |
| 428 | 1241 |
| 1242 GET_LIST_LENGTH (args, nargs); | |
| 1243 | |
| 1244 if (nargs & 1) /* Odd number of arguments? */ | |
| 1245 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs))); | |
| 1246 | |
| 2421 | 1247 GC_PROPERTY_LIST_LOOP_3 (symbol, val, args) |
| 428 | 1248 { |
| 1249 val = Feval (val); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1250 val = IGNORE_MULTIPLE_VALUES (val); |
| 428 | 1251 Fset (symbol, val); |
| 2421 | 1252 retval = val; |
| 428 | 1253 } |
| 1254 | |
| 2421 | 1255 END_GC_PROPERTY_LIST_LOOP (symbol); |
| 1256 | |
| 1257 return retval; | |
| 428 | 1258 } |
| 1259 | |
| 1260 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /* | |
| 1261 Return the argument, without evaluating it. `(quote x)' yields `x'. | |
| 3794 | 1262 |
| 3842 | 1263 `quote' differs from `function' in that it is a hint that an expression is |
| 1264 data, not a function. In particular, under some circumstances the byte | |
| 1265 compiler will compile an expression quoted with `function', but it will | |
| 1266 never do so for an expression quoted with `quote'. These issues are most | |
| 1267 important for lambda expressions (see `lambda'). | |
| 1268 | |
| 1269 There is an alternative, more readable, reader syntax for `quote': a Lisp | |
| 1270 object preceded by `''. Thus, `'x' is equivalent to `(quote x)', in all | |
| 1271 contexts. A print function may use either. Internally the expression is | |
| 1272 represented as `(quote x)'). | |
|
5265
5663ae9a8989
Warn at compile time, error at runtime, with (quote X Y), (function X Y).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
1273 |
|
5663ae9a8989
Warn at compile time, error at runtime, with (quote X Y), (function X Y).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
1274 arguments: (OBJECT) |
| 428 | 1275 */ |
| 1276 (args)) | |
| 1277 { | |
|
5207
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1278 int nargs; |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1279 |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1280 GET_LIST_LENGTH (args, nargs); |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1281 if (nargs != 1) |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1282 { |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1283 Fsignal (Qwrong_number_of_arguments, |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1284 list2 (Qquote, make_int (nargs))); |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1285 } |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1286 |
| 428 | 1287 return XCAR (args); |
| 1288 } | |
| 1289 | |
|
4744
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1290 /* Originally, this was just a function -- but `custom' used a garden- |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1291 variety version, so why not make it a subr? */ |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1292 DEFUN ("quote-maybe", Fquote_maybe, 1, 1, 0, /* |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1293 Quote EXPR if it is not self quoting. |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1294 |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1295 In contrast with `quote', this is a function, not a special form; its |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1296 argument is evaluated before `quote-maybe' is called. It returns either |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1297 EXPR (if it is self-quoting) or a list `(quote EXPR)' if it is not |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1298 self-quoting. Lists starting with the symbol `lambda' are regarded as |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1299 self-quoting. |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1300 */ |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1301 (expr)) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1302 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1303 if ((XTYPE (expr)) == Lisp_Type_Record) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1304 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1305 switch (XRECORD_LHEADER (expr)->type) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1306 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1307 case lrecord_type_symbol: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1308 if (NILP (expr) || (EQ (expr, Qt)) || SYMBOL_IS_KEYWORD (expr)) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1309 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1310 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1311 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1312 break; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1313 case lrecord_type_cons: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1314 if (EQ (XCAR (expr), Qlambda)) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1315 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1316 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1317 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1318 break; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1319 |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1320 case lrecord_type_vector: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1321 case lrecord_type_string: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1322 case lrecord_type_compiled_function: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1323 case lrecord_type_bit_vector: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1324 case lrecord_type_float: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1325 case lrecord_type_hash_table: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1326 case lrecord_type_char_table: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1327 case lrecord_type_range_table: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1328 case lrecord_type_bignum: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1329 case lrecord_type_ratio: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1330 case lrecord_type_bigfloat: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1331 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1332 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1333 return list2 (Qquote, expr); |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1334 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1335 |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1336 /* Fixnums and characters are self-quoting: */ |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1337 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1338 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1339 |
| 428 | 1340 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /* |
| 3842 | 1341 Return the argument, without evaluating it. `(function x)' yields `x'. |
| 1342 | |
| 1343 `function' differs from `quote' in that it is a hint that an expression is | |
| 1344 a function, not data. In particular, under some circumstances the byte | |
| 1345 compiler will compile an expression quoted with `function', but it will | |
| 1346 never do so for an expression quoted with `quote'. However, the byte | |
| 1347 compiler will not compile an expression buried in a data structure such as | |
| 1348 a vector or a list which is not syntactically a function. These issues are | |
| 1349 most important for lambda expressions (see `lambda'). | |
| 1350 | |
| 1351 There is an alternative, more readable, reader syntax for `function': a Lisp | |
| 1352 object preceded by `#''. Thus, #'x is equivalent to (function x), in all | |
| 1353 contexts. A print function may use either. Internally the expression is | |
| 1354 represented as `(function x)'). | |
|
5265
5663ae9a8989
Warn at compile time, error at runtime, with (quote X Y), (function X Y).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
1355 |
|
5663ae9a8989
Warn at compile time, error at runtime, with (quote X Y), (function X Y).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
1356 arguments: (SYMBOL-OR-LAMBDA) |
| 428 | 1357 */ |
| 1358 (args)) | |
| 1359 { | |
|
5207
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1360 int nargs; |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1361 |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1362 GET_LIST_LENGTH (args, nargs); |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1363 if (nargs != 1) |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1364 { |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1365 Fsignal (Qwrong_number_of_arguments, |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1366 list2 (Qfunction, make_int (nargs))); |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1367 } |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1368 |
| 428 | 1369 return XCAR (args); |
| 1370 } | |
| 1371 | |
| 1372 | |
| 1373 /************************************************************************/ | |
| 1374 /* Defining functions/variables */ | |
| 1375 /************************************************************************/ | |
| 1376 static Lisp_Object | |
| 1377 define_function (Lisp_Object name, Lisp_Object defn) | |
| 1378 { | |
| 1379 Ffset (name, defn); | |
|
4535
69a1eda3da06
Distinguish vars and functions in #'symbol-file, #'describe-{function,variable}
Aidan Kehoe <kehoea@parhasard.net>
parents:
4502
diff
changeset
|
1380 LOADHIST_ATTACH (Fcons (Qdefun, name)); |
| 428 | 1381 return name; |
| 1382 } | |
| 1383 | |
| 1384 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /* | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1385 Define NAME as a function. |
| 428 | 1386 The definition is (lambda ARGLIST [DOCSTRING] BODY...). |
| 1387 See also the function `interactive'. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1388 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1389 arguments: (NAME ARGLIST &optional DOCSTRING &rest BODY) |
| 428 | 1390 */ |
| 1391 (args)) | |
| 1392 { | |
| 1393 /* This function can GC */ | |
| 1394 return define_function (XCAR (args), | |
| 1395 Fcons (Qlambda, XCDR (args))); | |
| 1396 } | |
| 1397 | |
| 1398 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /* | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1399 Define NAME as a macro. |
| 428 | 1400 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...). |
| 1401 When the macro is called, as in (NAME ARGS...), | |
| 1402 the function (lambda ARGLIST BODY...) is applied to | |
| 1403 the list ARGS... as it appears in the expression, | |
| 1404 and the result should be a form to be evaluated instead of the original. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1405 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1406 arguments: (NAME ARGLIST &optional DOCSTRING &rest BODY) |
| 428 | 1407 */ |
| 1408 (args)) | |
| 1409 { | |
| 1410 /* This function can GC */ | |
| 1411 return define_function (XCAR (args), | |
| 1412 Fcons (Qmacro, Fcons (Qlambda, XCDR (args)))); | |
| 1413 } | |
| 1414 | |
| 1415 DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1416 Define SYMBOL as a variable. |
| 428 | 1417 You are not required to define a variable in order to use it, |
| 1418 but the definition can supply documentation and an initial value | |
| 1419 in a way that tags can recognize. | |
| 1420 | |
| 1421 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is | |
| 1422 void. (However, when you evaluate a defvar interactively, it acts like a | |
| 1423 defconst: SYMBOL's value is always set regardless of whether it's currently | |
| 1424 void.) | |
| 1425 If SYMBOL is buffer-local, its default value is what is set; | |
| 1426 buffer-local values are not affected. | |
| 1427 INITVALUE and DOCSTRING are optional. | |
| 1428 If DOCSTRING starts with *, this variable is identified as a user option. | |
| 442 | 1429 This means that M-x set-variable recognizes it. |
| 428 | 1430 If INITVALUE is missing, SYMBOL's value is not set. |
| 1431 | |
| 1432 In lisp-interaction-mode defvar is treated as defconst. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1433 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1434 arguments: (SYMBOL &optional INITVALUE DOCSTRING) |
| 428 | 1435 */ |
| 1436 (args)) | |
| 1437 { | |
| 1438 /* This function can GC */ | |
| 1439 Lisp_Object sym = XCAR (args); | |
| 1440 | |
| 1441 if (!NILP (args = XCDR (args))) | |
| 1442 { | |
| 1443 Lisp_Object val = XCAR (args); | |
| 1444 | |
| 1445 if (NILP (Fdefault_boundp (sym))) | |
| 1446 { | |
| 1447 struct gcpro gcpro1; | |
| 1448 GCPRO1 (val); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1449 val = IGNORE_MULTIPLE_VALUES (Feval (val)); |
| 428 | 1450 Fset_default (sym, val); |
| 1451 UNGCPRO; | |
| 1452 } | |
| 1453 | |
| 1454 if (!NILP (args = XCDR (args))) | |
| 1455 { | |
| 1456 Lisp_Object doc = XCAR (args); | |
| 1457 Fput (sym, Qvariable_documentation, doc); | |
| 1458 if (!NILP (args = XCDR (args))) | |
| 563 | 1459 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound); |
| 428 | 1460 } |
| 1461 } | |
| 1462 | |
| 1463 #ifdef I18N3 | |
| 1464 if (!NILP (Vfile_domain)) | |
| 1465 Fput (sym, Qvariable_domain, Vfile_domain); | |
| 1466 #endif | |
| 1467 | |
| 1468 LOADHIST_ATTACH (sym); | |
| 1469 return sym; | |
| 1470 } | |
| 1471 | |
| 1472 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1473 Define SYMBOL as a constant variable. |
| 428 | 1474 The intent is that programs do not change this value, but users may. |
| 1475 Always sets the value of SYMBOL to the result of evalling INITVALUE. | |
| 1476 If SYMBOL is buffer-local, its default value is what is set; | |
| 1477 buffer-local values are not affected. | |
| 1478 DOCSTRING is optional. | |
| 1479 If DOCSTRING starts with *, this variable is identified as a user option. | |
| 442 | 1480 This means that M-x set-variable recognizes it. |
| 428 | 1481 |
| 1482 Note: do not use `defconst' for user options in libraries that are not | |
| 1483 normally loaded, since it is useful for users to be able to specify | |
| 1484 their own values for such variables before loading the library. | |
| 1485 Since `defconst' unconditionally assigns the variable, | |
| 1486 it would override the user's choice. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1487 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1488 arguments: (SYMBOL &optional INITVALUE DOCSTRING) |
| 428 | 1489 */ |
| 1490 (args)) | |
| 1491 { | |
| 1492 /* This function can GC */ | |
| 1493 Lisp_Object sym = XCAR (args); | |
| 1494 Lisp_Object val = Feval (XCAR (args = XCDR (args))); | |
| 1495 struct gcpro gcpro1; | |
| 1496 | |
| 1497 GCPRO1 (val); | |
| 1498 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1499 val = IGNORE_MULTIPLE_VALUES (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1500 |
| 428 | 1501 Fset_default (sym, val); |
| 1502 | |
| 1503 UNGCPRO; | |
| 1504 | |
| 1505 if (!NILP (args = XCDR (args))) | |
| 1506 { | |
| 1507 Lisp_Object doc = XCAR (args); | |
| 1508 Fput (sym, Qvariable_documentation, doc); | |
| 1509 if (!NILP (args = XCDR (args))) | |
| 563 | 1510 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound); |
| 428 | 1511 } |
| 1512 | |
| 1513 #ifdef I18N3 | |
| 1514 if (!NILP (Vfile_domain)) | |
| 1515 Fput (sym, Qvariable_domain, Vfile_domain); | |
| 1516 #endif | |
| 1517 | |
| 1518 LOADHIST_ATTACH (sym); | |
| 1519 return sym; | |
| 1520 } | |
| 1521 | |
|
4502
8748a3f7ceb4
Handle varalias chains, custom variables in #'user-variable-p.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4162
diff
changeset
|
1522 /* XEmacs: user-variable-p is in symbols.c, since it needs to mess around |
|
8748a3f7ceb4
Handle varalias chains, custom variables in #'user-variable-p.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4162
diff
changeset
|
1523 with the symbol variable aliases. */ |
| 428 | 1524 |
| 1525 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /* | |
| 1526 Return result of expanding macros at top level of FORM. | |
| 1527 If FORM is not a macro call, it is returned unchanged. | |
| 1528 Otherwise, the macro is expanded and the expansion is considered | |
| 1529 in place of FORM. When a non-macro-call results, it is returned. | |
| 1530 | |
| 442 | 1531 The second optional arg ENVIRONMENT specifies an environment of macro |
| 428 | 1532 definitions to shadow the loaded ones for use in file byte-compilation. |
| 1533 */ | |
| 442 | 1534 (form, environment)) |
| 428 | 1535 { |
| 1536 /* This function can GC */ | |
| 1537 /* With cleanups from Hallvard Furuseth. */ | |
| 1538 REGISTER Lisp_Object expander, sym, def, tem; | |
| 1539 | |
| 1540 while (1) | |
| 1541 { | |
| 1542 /* Come back here each time we expand a macro call, | |
| 1543 in case it expands into another macro call. */ | |
| 1544 if (!CONSP (form)) | |
| 1545 break; | |
| 1546 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */ | |
| 1547 def = sym = XCAR (form); | |
| 1548 tem = Qnil; | |
| 1549 /* Trace symbols aliases to other symbols | |
| 1550 until we get a symbol that is not an alias. */ | |
| 1551 while (SYMBOLP (def)) | |
| 1552 { | |
| 1553 QUIT; | |
| 1554 sym = def; | |
| 442 | 1555 tem = Fassq (sym, environment); |
| 428 | 1556 if (NILP (tem)) |
| 1557 { | |
| 1558 def = XSYMBOL (sym)->function; | |
| 1559 if (!UNBOUNDP (def)) | |
| 1560 continue; | |
| 1561 } | |
| 1562 break; | |
| 1563 } | |
| 442 | 1564 /* Right now TEM is the result from SYM in ENVIRONMENT, |
| 428 | 1565 and if TEM is nil then DEF is SYM's function definition. */ |
| 1566 if (NILP (tem)) | |
| 1567 { | |
| 442 | 1568 /* SYM is not mentioned in ENVIRONMENT. |
| 428 | 1569 Look at its function definition. */ |
| 1570 if (UNBOUNDP (def) | |
| 1571 || !CONSP (def)) | |
| 1572 /* Not defined or definition not suitable */ | |
| 1573 break; | |
| 1574 if (EQ (XCAR (def), Qautoload)) | |
| 1575 { | |
| 1576 /* Autoloading function: will it be a macro when loaded? */ | |
| 1577 tem = Felt (def, make_int (4)); | |
| 1578 if (EQ (tem, Qt) || EQ (tem, Qmacro)) | |
| 1579 { | |
| 1580 /* Yes, load it and try again. */ | |
| 970 | 1581 /* do_autoload GCPROs both arguments */ |
| 428 | 1582 do_autoload (def, sym); |
| 1583 continue; | |
| 1584 } | |
| 1585 else | |
| 1586 break; | |
| 1587 } | |
| 1588 else if (!EQ (XCAR (def), Qmacro)) | |
| 1589 break; | |
| 1590 else expander = XCDR (def); | |
| 1591 } | |
| 1592 else | |
| 1593 { | |
| 1594 expander = XCDR (tem); | |
| 1595 if (NILP (expander)) | |
| 1596 break; | |
| 1597 } | |
| 1598 form = apply1 (expander, XCDR (form)); | |
| 1599 } | |
| 1600 return form; | |
| 1601 } | |
| 1602 | |
| 1603 | |
| 1604 /************************************************************************/ | |
| 1605 /* Non-local exits */ | |
| 1606 /************************************************************************/ | |
| 1607 | |
| 1318 | 1608 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1609 | |
| 1610 int | |
| 1611 proper_redisplay_wrapping_in_place (void) | |
| 1612 { | |
| 1613 return !in_display | |
| 1614 || ((get_inhibit_flags () & INTERNAL_INHIBIT_ERRORS) | |
| 1615 && (get_inhibit_flags () & INTERNAL_INHIBIT_THROWS)); | |
| 1616 } | |
| 1617 | |
| 1618 static void | |
| 1619 check_proper_critical_section_nonlocal_exit_protection (void) | |
| 1620 { | |
| 1621 assert_with_message | |
| 1622 (proper_redisplay_wrapping_in_place (), | |
| 1623 "Attempted non-local exit from within redisplay without being properly wrapped"); | |
| 1624 } | |
| 1625 | |
| 1626 static void | |
| 1627 check_proper_critical_section_lisp_protection (void) | |
| 1628 { | |
| 1629 assert_with_message | |
| 1630 (proper_redisplay_wrapping_in_place (), | |
| 1631 "Attempt to call Lisp code from within redisplay without being properly wrapped"); | |
| 1632 } | |
| 1633 | |
| 1634 #endif /* ERROR_CHECK_TRAPPING_PROBLEMS */ | |
| 1635 | |
| 428 | 1636 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /* |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1637 Eval BODY allowing nonlocal exits using `throw'. |
| 428 | 1638 TAG is evalled to get the tag to use. Then the BODY is executed. |
| 3577 | 1639 Within BODY, (throw TAG VAL) with same (`eq') tag exits BODY and this `catch'. |
| 428 | 1640 If no throw happens, `catch' returns the value of the last BODY form. |
| 1641 If a throw happens, it specifies the value to return from `catch'. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1642 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1643 arguments: (TAG &rest BODY) |
| 428 | 1644 */ |
| 1645 (args)) | |
| 1646 { | |
| 1647 /* This function can GC */ | |
| 1648 Lisp_Object tag = Feval (XCAR (args)); | |
| 1649 Lisp_Object body = XCDR (args); | |
| 2532 | 1650 return internal_catch (tag, Fprogn, body, 0, 0, 0); |
| 428 | 1651 } |
| 1652 | |
| 1653 /* Set up a catch, then call C function FUNC on argument ARG. | |
| 1654 FUNC should return a Lisp_Object. | |
| 1655 This is how catches are done from within C code. */ | |
| 1656 | |
| 1657 Lisp_Object | |
| 1658 internal_catch (Lisp_Object tag, | |
| 1659 Lisp_Object (*func) (Lisp_Object arg), | |
| 1660 Lisp_Object arg, | |
| 853 | 1661 int * volatile threw, |
| 2532 | 1662 Lisp_Object * volatile thrown_tag, |
| 1663 Lisp_Object * volatile backtrace_before_throw) | |
| 428 | 1664 { |
| 1665 /* This structure is made part of the chain `catchlist'. */ | |
| 1666 struct catchtag c; | |
| 1667 | |
| 1668 /* Fill in the components of c, and put it on the list. */ | |
| 1669 c.next = catchlist; | |
| 1670 c.tag = tag; | |
| 853 | 1671 c.actual_tag = Qnil; |
| 2532 | 1672 c.backtrace = Qnil; |
| 428 | 1673 c.val = Qnil; |
| 1674 c.backlist = backtrace_list; | |
| 1675 #if 0 /* FSFmacs */ | |
| 1676 /* #### */ | |
| 1677 c.handlerlist = handlerlist; | |
| 1678 #endif | |
| 1679 c.lisp_eval_depth = lisp_eval_depth; | |
| 1680 c.pdlcount = specpdl_depth(); | |
| 1681 #if 0 /* FSFmacs */ | |
| 1682 c.poll_suppress_count = async_timer_suppress_count; | |
| 1683 #endif | |
| 1684 c.gcpro = gcprolist; | |
| 1685 catchlist = &c; | |
| 1686 | |
| 1687 /* Call FUNC. */ | |
| 1688 if (SETJMP (c.jmp)) | |
| 1689 { | |
| 1690 /* Throw works by a longjmp that comes right here. */ | |
| 1691 if (threw) *threw = 1; | |
| 853 | 1692 if (thrown_tag) *thrown_tag = c.actual_tag; |
| 2532 | 1693 if (backtrace_before_throw) *backtrace_before_throw = c.backtrace; |
| 428 | 1694 return c.val; |
| 1695 } | |
| 1696 c.val = (*func) (arg); | |
| 1697 if (threw) *threw = 0; | |
| 853 | 1698 if (thrown_tag) *thrown_tag = Qnil; |
| 428 | 1699 catchlist = c.next; |
| 853 | 1700 check_catchlist_sanity (); |
| 428 | 1701 return c.val; |
| 1702 } | |
| 1703 | |
| 1704 | |
| 1705 /* Unwind the specbind, catch, and handler stacks back to CATCH, and | |
| 1706 jump to that CATCH, returning VALUE as the value of that catch. | |
| 1707 | |
| 2297 | 1708 This is the guts of Fthrow and Fsignal; they differ only in the |
| 1709 way they choose the catch tag to throw to. A catch tag for a | |
| 428 | 1710 condition-case form has a TAG of Qnil. |
| 1711 | |
| 1712 Before each catch is discarded, unbind all special bindings and | |
| 1713 execute all unwind-protect clauses made above that catch. Unwind | |
| 1714 the handler stack as we go, so that the proper handlers are in | |
| 1715 effect for each unwind-protect clause we run. At the end, restore | |
| 1716 some static info saved in CATCH, and longjmp to the location | |
| 1717 specified in the | |
| 1718 | |
| 1719 This is used for correct unwinding in Fthrow and Fsignal. */ | |
| 1720 | |
| 2268 | 1721 static DECLARE_DOESNT_RETURN (unwind_to_catch (struct catchtag *, Lisp_Object, |
| 1722 Lisp_Object)); | |
| 1723 | |
| 1724 static DOESNT_RETURN | |
| 853 | 1725 unwind_to_catch (struct catchtag *c, Lisp_Object val, Lisp_Object tag) |
| 428 | 1726 { |
| 1727 REGISTER int last_time; | |
| 1728 | |
| 1729 /* Unwind the specbind, catch, and handler stacks back to CATCH | |
| 1730 Before each catch is discarded, unbind all special bindings | |
| 1731 and execute all unwind-protect clauses made above that catch. | |
| 1732 At the end, restore some static info saved in CATCH, | |
| 1733 and longjmp to the location specified. | |
| 1734 */ | |
| 1735 | |
| 1736 /* Save the value somewhere it will be GC'ed. | |
| 1737 (Can't overwrite tag slot because an unwind-protect may | |
| 1738 want to throw to this same tag, which isn't yet invalid.) */ | |
| 1739 c->val = val; | |
| 853 | 1740 c->actual_tag = tag; |
| 428 | 1741 |
| 1742 #if 0 /* FSFmacs */ | |
| 1743 /* Restore the polling-suppression count. */ | |
| 1744 set_poll_suppress_count (catch->poll_suppress_count); | |
| 1745 #endif | |
| 1746 | |
| 617 | 1747 #if 1 |
| 428 | 1748 do |
| 1749 { | |
| 1750 last_time = catchlist == c; | |
| 1751 | |
| 1752 /* Unwind the specpdl stack, and then restore the proper set of | |
| 1753 handlers. */ | |
| 771 | 1754 unbind_to (catchlist->pdlcount); |
| 428 | 1755 catchlist = catchlist->next; |
| 853 | 1756 check_catchlist_sanity (); |
| 428 | 1757 } |
| 1758 while (! last_time); | |
| 617 | 1759 #else |
| 1760 /* Former XEmacs code. This is definitely not as correct because | |
| 1761 there may be a number of catches we're unwinding, and a number | |
| 1762 of unwind-protects in the process. By not undoing the catches till | |
| 1763 the end, there may be invalid catches still current. (This would | |
| 1764 be a particular problem with code like this: | |
| 1765 | |
| 1766 (catch 'foo | |
| 1767 (call-some-code-which-does... | |
| 1768 (catch 'bar | |
| 1769 (unwind-protect | |
| 1770 (call-some-code-which-does... | |
| 1771 (catch 'bar | |
| 1772 (call-some-code-which-does... | |
| 1773 (throw 'foo nil)))) | |
| 1774 (throw 'bar nil))))) | |
| 1775 | |
| 1776 This would try to throw to the inner (catch 'bar)! | |
| 1777 | |
| 1778 --ben | |
| 1779 */ | |
| 428 | 1780 /* Unwind the specpdl stack */ |
| 771 | 1781 unbind_to (c->pdlcount); |
| 428 | 1782 catchlist = c->next; |
| 853 | 1783 check_catchlist_sanity (); |
| 617 | 1784 #endif /* Former code */ |
| 428 | 1785 |
| 1204 | 1786 UNWIND_GCPRO_TO (c->gcpro); |
| 1292 | 1787 if (profiling_active) |
| 1788 { | |
| 1789 while (backtrace_list != c->backlist) | |
| 1790 { | |
| 1791 profile_record_unwind (backtrace_list); | |
| 1792 backtrace_list = backtrace_list->next; | |
| 1793 } | |
| 1794 } | |
| 1795 else | |
| 1796 backtrace_list = c->backlist; | |
| 428 | 1797 lisp_eval_depth = c->lisp_eval_depth; |
| 1798 | |
| 442 | 1799 #ifdef DEFEND_AGAINST_THROW_RECURSION |
| 428 | 1800 throw_level = 0; |
| 1801 #endif | |
| 1802 LONGJMP (c->jmp, 1); | |
| 1803 } | |
| 1804 | |
|
5348
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1805 DECLARE_DOESNT_RETURN (throw_or_bomb_out_unsafe (Lisp_Object, Lisp_Object, int, |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1806 Lisp_Object, Lisp_Object)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1807 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1808 DOESNT_RETURN |
|
5348
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1809 throw_or_bomb_out_unsafe (Lisp_Object tag, Lisp_Object val, int bomb_out_p, |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1810 Lisp_Object sig, Lisp_Object data) |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1811 { |
| 428 | 1812 /* If bomb_out_p is t, this is being called from Fsignal as a |
| 1813 "last resort" when there is no handler for this error and | |
| 1814 the debugger couldn't be invoked, so we are throwing to | |
| 3025 | 1815 `top-level'. If this tag doesn't exist (happens during the |
| 428 | 1816 initialization stages) we would get in an infinite recursive |
| 1817 Fsignal/Fthrow loop, so instead we bomb out to the | |
| 1818 really-early-error-handler. | |
| 1819 | |
| 1820 Note that in fact the only time that the "last resort" | |
| 3025 | 1821 occurs is when there's no catch for `top-level' -- the |
| 1822 `top-level' catch and the catch-all error handler are | |
| 428 | 1823 established at the same time, in initial_command_loop/ |
| 1824 top_level_1. | |
| 1825 | |
| 853 | 1826 [[#### Fix this horrifitude!]] |
| 1827 | |
| 1828 I don't think this is horrifitude, just defensive programming. --ben | |
| 428 | 1829 */ |
| 1830 | |
| 1831 while (1) | |
| 1832 { | |
| 1833 REGISTER struct catchtag *c; | |
| 1834 | |
| 1835 #if 0 /* FSFmacs */ | |
| 1836 if (!NILP (tag)) /* #### */ | |
| 1837 #endif | |
| 1838 for (c = catchlist; c; c = c->next) | |
| 1839 { | |
| 2532 | 1840 if (EQ (c->tag, Vcatch_everything_tag)) |
| 1841 c->backtrace = maybe_get_trapping_problems_backtrace (); | |
| 853 | 1842 if (EQ (c->tag, tag) || EQ (c->tag, Vcatch_everything_tag)) |
| 1843 unwind_to_catch (c, val, tag); | |
| 428 | 1844 } |
| 1845 if (!bomb_out_p) | |
| 1846 tag = Fsignal (Qno_catch, list2 (tag, val)); | |
| 1847 else | |
| 1848 call1 (Qreally_early_error_handler, Fcons (sig, data)); | |
| 1849 } | |
| 1850 } | |
|
5348
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1851 |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1852 DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int, |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1853 Lisp_Object, Lisp_Object)); |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1854 |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1855 DOESNT_RETURN |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1856 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p, |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1857 Lisp_Object sig, Lisp_Object data) |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1858 { |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1859 #ifdef DEFEND_AGAINST_THROW_RECURSION |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1860 /* die if we recurse more than is reasonable */ |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1861 assert (++throw_level <= 20); |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1862 #endif |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1863 |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1864 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1865 check_proper_critical_section_nonlocal_exit_protection (); |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1866 #endif |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1867 throw_or_bomb_out_unsafe (tag, val, bomb_out_p, sig, data); |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1868 } |
| 428 | 1869 |
| 1870 /* See above, where CATCHLIST is defined, for a description of how | |
| 1871 Fthrow() works. | |
| 1872 | |
| 1873 Fthrow() is also called by Fsignal(), to do a non-local jump | |
| 1874 back to the appropriate condition-case handler after (maybe) | |
| 1875 the debugger is entered. In that case, TAG is the value | |
| 1876 of Vcondition_handlers that was in place just after the | |
| 1877 condition-case handler was set up. The car of this will be | |
| 1878 some data referring to the handler: Its car will be Qunbound | |
| 1879 (thus, this tag can never be generated by Lisp code), and | |
| 1880 its CDR will be the HANDLERS argument to condition_case_1() | |
| 1881 (either Qerror, Qt, or a list of handlers as in `condition-case'). | |
| 1882 This works fine because Fthrow() does not care what TAG was | |
| 1883 passed to it: it just looks up the catch list for something | |
| 1884 that is EQ() to TAG. When it finds it, it will longjmp() | |
| 1885 back to the place that established the catch (in this case, | |
| 1886 condition_case_1). See below for more info. | |
| 1887 */ | |
| 1888 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1889 DEFUN_NORETURN ("throw", Fthrow, 2, UNEVALLED, 0, /* |
| 444 | 1890 Throw to the catch for TAG and return VALUE from it. |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1891 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1892 Both TAG and VALUE are evalled, and multiple values in VALUE will be passed |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1893 back. Tags are the same if and only if they are `eq'. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1894 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1895 arguments: (TAG VALUE) |
| 428 | 1896 */ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1897 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1898 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1899 int nargs; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1900 Lisp_Object tag, value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1901 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1902 GET_LIST_LENGTH (args, nargs); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1903 if (nargs != 2) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1904 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1905 Fsignal (Qwrong_number_of_arguments, list2 (Qthrow, make_int (nargs))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1906 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1907 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1908 tag = IGNORE_MULTIPLE_VALUES (Feval (XCAR(args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1909 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1910 value = Feval (XCAR (XCDR (args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1911 |
| 444 | 1912 throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */ |
| 2268 | 1913 RETURN_NOT_REACHED (Qnil); |
| 428 | 1914 } |
| 1915 | |
| 1916 DEFUN ("unwind-protect", Funwind_protect, 1, UNEVALLED, 0, /* | |
| 1917 Do BODYFORM, protecting with UNWINDFORMS. | |
| 1918 If BODYFORM completes normally, its value is returned | |
| 1919 after executing the UNWINDFORMS. | |
| 1920 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1921 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1922 arguments: (BODYFORM &rest UNWINDFORMS) |
| 428 | 1923 */ |
| 1924 (args)) | |
| 1925 { | |
| 1926 /* This function can GC */ | |
| 1927 int speccount = specpdl_depth(); | |
| 1928 | |
| 1929 record_unwind_protect (Fprogn, XCDR (args)); | |
| 771 | 1930 return unbind_to_1 (speccount, Feval (XCAR (args))); |
| 428 | 1931 } |
| 1932 | |
| 1933 | |
| 1934 /************************************************************************/ | |
| 1292 | 1935 /* Trapping errors */ |
| 428 | 1936 /************************************************************************/ |
| 1937 | |
| 1938 static Lisp_Object | |
| 1939 condition_bind_unwind (Lisp_Object loser) | |
| 1940 { | |
| 617 | 1941 /* There is no problem freeing stuff here like there is in |
| 1942 condition_case_unwind(), because there are no outside pointers | |
| 1943 (like the tag below in the catchlist) pointing to the objects. */ | |
| 853 | 1944 |
| 428 | 1945 /* ((handler-fun . handler-args) ... other handlers) */ |
| 1946 Lisp_Object tem = XCAR (loser); | |
| 853 | 1947 int first = 1; |
| 428 | 1948 |
| 1949 while (CONSP (tem)) | |
| 1950 { | |
| 853 | 1951 Lisp_Object victim = tem; |
| 1952 if (first && OPAQUE_PTRP (XCAR (victim))) | |
| 1953 free_opaque_ptr (XCAR (victim)); | |
| 1954 first = 0; | |
| 1955 tem = XCDR (victim); | |
| 428 | 1956 free_cons (victim); |
| 1957 } | |
| 1958 | |
| 1959 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */ | |
| 853 | 1960 Vcondition_handlers = XCDR (loser); |
| 1961 | |
| 1962 free_cons (loser); | |
| 428 | 1963 return Qnil; |
| 1964 } | |
| 1965 | |
| 1966 static Lisp_Object | |
| 1967 condition_case_unwind (Lisp_Object loser) | |
| 1968 { | |
| 1969 /* ((<unbound> . clauses) ... other handlers */ | |
| 617 | 1970 /* NO! Doing this now leaves the tag deleted in a still-active |
| 1971 catch. With the recent changes to unwind_to_catch(), the | |
| 1972 evil situation might not happen any more; it certainly could | |
| 1973 happen before because it did. But it's very precarious to rely | |
| 1974 on something like this. #### Instead we should rewrite, adopting | |
| 1975 the FSF's mechanism with a struct handler instead of | |
| 1976 Vcondition_handlers; then we have NO Lisp-object structures used | |
| 1977 to hold all of the values, and there's no possibility either of | |
| 1978 crashes from freeing objects too quickly, or objects not getting | |
| 1979 freed and hanging around till the next GC. | |
| 1980 | |
| 1981 In practice, the extra consing here should not matter because | |
| 1982 it only happens when we throw past the condition-case, which almost | |
| 1983 always is the result of an error. Most of the time, there will be | |
| 1984 no error, and we will free the objects below in the main function. | |
| 1985 | |
| 1986 --ben | |
| 1987 | |
| 1988 DO NOT DO: free_cons (XCAR (loser)); | |
| 1989 */ | |
| 1990 | |
| 428 | 1991 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */ |
| 617 | 1992 Vcondition_handlers = XCDR (loser); |
| 1993 | |
| 1994 /* DO NOT DO: free_cons (loser); */ | |
| 428 | 1995 return Qnil; |
| 1996 } | |
| 1997 | |
| 1998 /* Split out from condition_case_3 so that primitive C callers | |
| 1999 don't have to cons up a lisp handler form to be evaluated. */ | |
| 2000 | |
| 2001 /* Call a function BFUN of one argument BARG, trapping errors as | |
| 2002 specified by HANDLERS. If no error occurs that is indicated by | |
| 2003 HANDLERS as something to be caught, the return value of this | |
| 2004 function is the return value from BFUN. If such an error does | |
| 2005 occur, HFUN is called, and its return value becomes the | |
| 2006 return value of condition_case_1(). The second argument passed | |
| 2007 to HFUN will always be HARG. The first argument depends on | |
| 2008 HANDLERS: | |
| 2009 | |
| 2010 If HANDLERS is Qt, all errors (this includes QUIT, but not | |
| 2011 non-local exits with `throw') cause HFUN to be invoked, and VAL | |
| 2012 (the first argument to HFUN) is a cons (SIG . DATA) of the | |
| 2013 arguments passed to `signal'. The debugger is not invoked even if | |
| 2014 `debug-on-error' was set. | |
| 2015 | |
| 2016 A HANDLERS value of Qerror is the same as Qt except that the | |
| 2017 debugger is invoked if `debug-on-error' was set. | |
| 2018 | |
| 2019 Otherwise, HANDLERS should be a list of lists (CONDITION-NAME BODY ...) | |
| 2020 exactly as in `condition-case', and errors will be trapped | |
| 2021 as indicated in HANDLERS. VAL (the first argument to HFUN) will | |
| 2022 be a cons whose car is the cons (SIG . DATA) and whose CDR is the | |
| 2023 list (BODY ...) from the appropriate slot in HANDLERS. | |
| 2024 | |
| 2025 This function pushes HANDLERS onto the front of Vcondition_handlers | |
| 2026 (actually with a Qunbound marker as well -- see Fthrow() above | |
| 2027 for why), establishes a catch whose tag is this new value of | |
| 2028 Vcondition_handlers, and calls BFUN. When Fsignal() is called, | |
| 2029 it calls Fthrow(), setting TAG to this same new value of | |
| 2030 Vcondition_handlers and setting VAL to the same thing that will | |
| 2031 be passed to HFUN, as above. Fthrow() longjmp()s back to the | |
| 2032 jump point we just established, and we in turn just call the | |
| 2033 HFUN and return its value. | |
| 2034 | |
| 2035 For a real condition-case, HFUN will always be | |
| 2036 run_condition_case_handlers() and HARG is the argument VAR | |
| 2037 to condition-case. That function just binds VAR to the cons | |
| 2038 (SIG . DATA) that is the CAR of VAL, and calls the handler | |
| 2039 (BODY ...) that is the CDR of VAL. Note that before calling | |
| 2040 Fthrow(), Fsignal() restored Vcondition_handlers to the value | |
| 2041 it had *before* condition_case_1() was called. This maintains | |
| 2042 consistency (so that the state of things at exit of | |
| 2043 condition_case_1() is the same as at entry), and implies | |
| 2044 that the handler can signal the same error again (possibly | |
| 2045 after processing of its own), without getting in an infinite | |
| 2046 loop. */ | |
| 2047 | |
| 2048 Lisp_Object | |
| 2049 condition_case_1 (Lisp_Object handlers, | |
| 2050 Lisp_Object (*bfun) (Lisp_Object barg), | |
| 2051 Lisp_Object barg, | |
| 2052 Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg), | |
| 2053 Lisp_Object harg) | |
| 2054 { | |
| 2055 int speccount = specpdl_depth(); | |
| 2056 struct catchtag c; | |
| 617 | 2057 struct gcpro gcpro1, gcpro2, gcpro3; |
| 428 | 2058 |
| 2059 #if 0 /* FSFmacs */ | |
| 2060 c.tag = Qnil; | |
| 2061 #else | |
| 2062 /* Do consing now so out-of-memory error happens up front */ | |
| 2063 /* (unbound . stuff) is a special condition-case kludge marker | |
| 2064 which is known specially by Fsignal. | |
| 617 | 2065 [[ This is an abomination, but to fix it would require either |
| 428 | 2066 making condition_case cons (a union of the conditions of the clauses) |
| 617 | 2067 or changing the byte-compiler output (no thanks).]] |
| 2068 | |
| 2069 The above comment is clearly wrong. FSF does not do it this way | |
| 2070 and did not change the byte-compiler output. Instead they use a | |
| 2071 `struct handler' to hold the various values (in place of our | |
| 2072 Vcondition_handlers) and chain them together, with pointers from | |
| 2073 the `struct catchtag' to the `struct handler'. We should perhaps | |
| 2074 consider moving to something similar, but not before I merge my | |
| 2075 stderr-proc workspace, which contains changes to these | |
| 2076 functions. --ben */ | |
| 428 | 2077 c.tag = noseeum_cons (noseeum_cons (Qunbound, handlers), |
| 2078 Vcondition_handlers); | |
| 2079 #endif | |
| 2080 c.val = Qnil; | |
| 853 | 2081 c.actual_tag = Qnil; |
| 2532 | 2082 c.backtrace = Qnil; |
| 428 | 2083 c.backlist = backtrace_list; |
| 2084 #if 0 /* FSFmacs */ | |
| 2085 /* #### */ | |
| 2086 c.handlerlist = handlerlist; | |
| 2087 #endif | |
| 2088 c.lisp_eval_depth = lisp_eval_depth; | |
| 2089 c.pdlcount = specpdl_depth(); | |
| 2090 #if 0 /* FSFmacs */ | |
| 2091 c.poll_suppress_count = async_timer_suppress_count; | |
| 2092 #endif | |
| 2093 c.gcpro = gcprolist; | |
| 2094 /* #### FSFmacs does the following statement *after* the setjmp(). */ | |
| 2095 c.next = catchlist; | |
| 2096 | |
| 2097 if (SETJMP (c.jmp)) | |
| 2098 { | |
| 2099 /* throw does ungcpro, etc */ | |
| 2100 return (*hfun) (c.val, harg); | |
| 2101 } | |
| 2102 | |
| 2103 record_unwind_protect (condition_case_unwind, c.tag); | |
| 2104 | |
| 2105 catchlist = &c; | |
| 2106 #if 0 /* FSFmacs */ | |
| 2107 h.handler = handlers; | |
| 2108 h.var = Qnil; | |
| 2109 h.next = handlerlist; | |
| 2110 h.tag = &c; | |
| 2111 handlerlist = &h; | |
| 2112 #else | |
| 2113 Vcondition_handlers = c.tag; | |
| 2114 #endif | |
| 2115 GCPRO1 (harg); /* Somebody has to gc-protect */ | |
| 2116 c.val = ((*bfun) (barg)); | |
| 2117 UNGCPRO; | |
| 617 | 2118 |
| 2119 /* Once we change `catchlist' below, the stuff in c will not be GCPRO'd. */ | |
| 2120 GCPRO3 (harg, c.val, c.tag); | |
| 2121 | |
| 428 | 2122 catchlist = c.next; |
| 853 | 2123 check_catchlist_sanity (); |
| 617 | 2124 /* Note: The unbind also resets Vcondition_handlers. Maybe we should |
| 2125 delete this here. */ | |
| 428 | 2126 Vcondition_handlers = XCDR (c.tag); |
| 771 | 2127 unbind_to (speccount); |
| 617 | 2128 |
| 2129 UNGCPRO; | |
| 2130 /* free the conses *after* the unbind, because the unbind will run | |
| 2131 condition_case_unwind above. */ | |
| 853 | 2132 free_cons (XCAR (c.tag)); |
| 2133 free_cons (c.tag); | |
| 617 | 2134 return c.val; |
| 428 | 2135 } |
| 2136 | |
| 2137 static Lisp_Object | |
| 2138 run_condition_case_handlers (Lisp_Object val, Lisp_Object var) | |
| 2139 { | |
| 2140 /* This function can GC */ | |
| 2141 #if 0 /* FSFmacs */ | |
| 2142 if (!NILP (h.var)) | |
| 2143 specbind (h.var, c.val); | |
| 2144 val = Fprogn (Fcdr (h.chosen_clause)); | |
| 2145 | |
| 2146 /* Note that this just undoes the binding of h.var; whoever | |
| 2147 longjmp()ed to us unwound the stack to c.pdlcount before | |
| 2148 throwing. */ | |
| 771 | 2149 unbind_to (c.pdlcount); |
| 428 | 2150 return val; |
| 2151 #else | |
| 2152 int speccount; | |
| 2153 | |
| 2154 CHECK_TRUE_LIST (val); | |
| 2155 if (NILP (var)) | |
| 2156 return Fprogn (Fcdr (val)); /* tail call */ | |
| 2157 | |
| 2158 speccount = specpdl_depth(); | |
| 2159 specbind (var, Fcar (val)); | |
| 2160 val = Fprogn (Fcdr (val)); | |
| 771 | 2161 return unbind_to_1 (speccount, val); |
| 428 | 2162 #endif |
| 2163 } | |
| 2164 | |
| 2165 /* Here for bytecode to call non-consfully. This is exactly like | |
| 2166 condition-case except that it takes three arguments rather | |
| 2167 than a single list of arguments. */ | |
| 2168 Lisp_Object | |
| 2169 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers) | |
| 2170 { | |
| 2171 /* This function can GC */ | |
| 2172 EXTERNAL_LIST_LOOP_2 (handler, handlers) | |
| 2173 { | |
| 2174 if (NILP (handler)) | |
| 2175 ; | |
| 2176 else if (CONSP (handler)) | |
| 2177 { | |
| 2178 Lisp_Object conditions = XCAR (handler); | |
| 2179 /* CONDITIONS must a condition name or a list of condition names */ | |
| 2180 if (SYMBOLP (conditions)) | |
| 2181 ; | |
| 2182 else | |
| 2183 { | |
| 2184 EXTERNAL_LIST_LOOP_2 (condition, conditions) | |
| 2185 if (!SYMBOLP (condition)) | |
| 2186 goto invalid_condition_handler; | |
| 2187 } | |
| 2188 } | |
| 2189 else | |
| 2190 { | |
| 2191 invalid_condition_handler: | |
| 563 | 2192 sferror ("Invalid condition handler", handler); |
| 428 | 2193 } |
| 2194 } | |
| 2195 | |
| 2196 CHECK_SYMBOL (var); | |
| 2197 | |
| 2198 return condition_case_1 (handlers, | |
| 2199 Feval, bodyform, | |
| 2200 run_condition_case_handlers, | |
| 2201 var); | |
| 2202 } | |
| 2203 | |
| 2204 DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /* | |
| 2205 Regain control when an error is signalled. | |
| 2206 Usage looks like (condition-case VAR BODYFORM HANDLERS...). | |
| 2207 Executes BODYFORM and returns its value if no error happens. | |
| 2208 Each element of HANDLERS looks like (CONDITION-NAME BODY...) | |
| 2209 where the BODY is made of Lisp expressions. | |
| 2210 | |
| 771 | 2211 A typical usage of `condition-case' looks like this: |
| 2212 | |
| 2213 (condition-case nil | |
| 2214 ;; you need a progn here if you want more than one statement ... | |
| 2215 (progn | |
| 2216 (do-something) | |
| 2217 (do-something-else)) | |
| 2218 (error | |
| 2219 (issue-warning-or) | |
| 2220 ;; but strangely, you don't need one here. | |
| 2221 (return-a-value-etc) | |
| 2222 )) | |
| 2223 | |
| 428 | 2224 A handler is applicable to an error if CONDITION-NAME is one of the |
| 2225 error's condition names. If an error happens, the first applicable | |
| 2226 handler is run. As a special case, a CONDITION-NAME of t matches | |
| 2227 all errors, even those without the `error' condition name on them | |
| 2228 \(e.g. `quit'). | |
| 2229 | |
| 2230 The car of a handler may be a list of condition names | |
| 2231 instead of a single condition name. | |
| 2232 | |
| 2233 When a handler handles an error, | |
| 2234 control returns to the condition-case and the handler BODY... is executed | |
| 2235 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA). | |
| 2236 VAR may be nil; then you do not get access to the signal information. | |
| 2237 | |
| 2238 The value of the last BODY form is returned from the condition-case. | |
| 2239 See also the function `signal' for more info. | |
| 2240 | |
| 2241 Note that at the time the condition handler is invoked, the Lisp stack | |
| 2242 and the current catches, condition-cases, and bindings have all been | |
| 2243 popped back to the state they were in just before the call to | |
| 2244 `condition-case'. This means that resignalling the error from | |
| 2245 within the handler will not result in an infinite loop. | |
| 2246 | |
| 2247 If you want to establish an error handler that is called with the | |
| 2248 Lisp stack, bindings, etc. as they were when `signal' was called, | |
| 2249 rather than when the handler was set, use `call-with-condition-handler'. | |
| 2250 */ | |
| 2251 (args)) | |
| 2252 { | |
| 2253 /* This function can GC */ | |
| 2254 Lisp_Object var = XCAR (args); | |
| 2255 Lisp_Object bodyform = XCAR (XCDR (args)); | |
| 2256 Lisp_Object handlers = XCDR (XCDR (args)); | |
| 2257 return condition_case_3 (bodyform, var, handlers); | |
| 2258 } | |
| 2259 | |
| 2260 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /* | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2261 Call FUNCTION with arguments ARGS, regaining control on error. |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2262 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2263 This function is similar to `condition-case', but HANDLER is invoked |
| 428 | 2264 with the same environment (Lisp stack, bindings, catches, condition-cases) |
| 2265 that was current when `signal' was called, rather than when the handler | |
| 2266 was established. | |
| 2267 | |
| 2268 HANDLER should be a function of one argument, which is a cons of the args | |
| 2269 \(SIG . DATA) that were passed to `signal'. It is invoked whenever | |
| 2270 `signal' is called (this differs from `condition-case', which allows | |
| 2271 you to specify which errors are trapped). If the handler function | |
| 2272 returns, `signal' continues as if the handler were never invoked. | |
| 2273 \(It continues to look for handlers established earlier than this one, | |
| 2274 and invokes the standard error-handler if none is found.) | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2275 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2276 arguments: (HANDLER FUNCTION &rest ARGS) |
| 428 | 2277 */ |
| 2278 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */ | |
| 2279 { | |
| 2280 /* This function can GC */ | |
| 2281 int speccount = specpdl_depth(); | |
| 2282 Lisp_Object tem; | |
| 2283 | |
| 853 | 2284 tem = Ffunction_max_args (args[0]); |
| 2285 if (! (XINT (Ffunction_min_args (args[0])) <= 1 | |
| 2286 && (NILP (tem) || 1 <= XINT (tem)))) | |
| 2287 invalid_argument ("Must be function of one argument", args[0]); | |
| 2288 | |
| 2289 /* (handler-fun . handler-args) but currently there are no handler-args */ | |
| 428 | 2290 tem = noseeum_cons (list1 (args[0]), Vcondition_handlers); |
| 2291 record_unwind_protect (condition_bind_unwind, tem); | |
| 2292 Vcondition_handlers = tem; | |
| 2293 | |
| 2294 /* Caller should have GC-protected args */ | |
| 771 | 2295 return unbind_to_1 (speccount, Ffuncall (nargs - 1, args + 1)); |
| 428 | 2296 } |
| 2297 | |
| 853 | 2298 /* This is the C version of the above function. It calls FUN, passing it |
| 2299 ARG, first setting up HANDLER to catch signals in the environment in | |
| 2300 which they were signalled. (HANDLER is only invoked if there was no | |
| 2301 handler (either from condition-case or call-with-condition-handler) set | |
| 2302 later on that handled the signal; therefore, this is a real error. | |
| 2303 | |
| 2304 HANDLER is invoked with three arguments: the ERROR-SYMBOL and DATA as | |
| 2305 passed to `signal', and HANDLER_ARG. Originally I made HANDLER_ARG and | |
| 2306 ARG be void * to facilitate passing structures, but I changed to | |
| 2307 Lisp_Objects because all the other C interfaces to catch/condition-case/etc. | |
| 2308 take Lisp_Objects, and it is easy enough to use make_opaque_ptr() et al. | |
| 2309 to convert between Lisp_Objects and structure pointers. */ | |
| 2310 | |
| 2311 Lisp_Object | |
| 2312 call_with_condition_handler (Lisp_Object (*handler) (Lisp_Object, Lisp_Object, | |
| 2313 Lisp_Object), | |
| 2314 Lisp_Object handler_arg, | |
| 2315 Lisp_Object (*fun) (Lisp_Object), | |
| 2316 Lisp_Object arg) | |
| 2317 { | |
| 2318 /* This function can GC */ | |
| 1111 | 2319 int speccount = specpdl_depth (); |
| 853 | 2320 Lisp_Object tem; |
| 2321 | |
| 2322 /* ((handler-fun . (handler-arg . nil)) ... ) */ | |
| 1111 | 2323 tem = noseeum_cons (noseeum_cons (make_opaque_ptr ((void *) handler), |
| 853 | 2324 noseeum_cons (handler_arg, Qnil)), |
| 2325 Vcondition_handlers); | |
| 2326 record_unwind_protect (condition_bind_unwind, tem); | |
| 2327 Vcondition_handlers = tem; | |
| 2328 | |
| 2329 return unbind_to_1 (speccount, (*fun) (arg)); | |
| 2330 } | |
| 2331 | |
| 428 | 2332 static int |
| 2333 condition_type_p (Lisp_Object type, Lisp_Object conditions) | |
| 2334 { | |
| 2335 if (EQ (type, Qt)) | |
| 2336 /* (condition-case c # (t c)) catches -all- signals | |
| 2337 * Use with caution! */ | |
| 2338 return 1; | |
| 2339 | |
| 2340 if (SYMBOLP (type)) | |
| 2341 return !NILP (Fmemq (type, conditions)); | |
| 2342 | |
| 2343 for (; CONSP (type); type = XCDR (type)) | |
| 2344 if (!NILP (Fmemq (XCAR (type), conditions))) | |
| 2345 return 1; | |
| 2346 | |
| 2347 return 0; | |
| 2348 } | |
| 2349 | |
| 2350 static Lisp_Object | |
| 2351 return_from_signal (Lisp_Object value) | |
| 2352 { | |
| 2353 #if 1 | |
| 2354 /* Most callers are not prepared to handle gc if this | |
| 2355 returns. So, since this feature is not very useful, | |
| 2356 take it out. */ | |
| 2357 /* Have called debugger; return value to signaller */ | |
| 2358 return value; | |
| 2359 #else /* But the reality is that that stinks, because: */ | |
| 2360 /* GACK!!! Really want some way for debug-on-quit errors | |
| 2361 to be continuable!! */ | |
| 563 | 2362 signal_error (Qunimplemented, |
| 2363 "Returning a value from an error is no longer supported", | |
| 2364 Qunbound); | |
| 428 | 2365 #endif |
| 2366 } | |
| 2367 | |
| 2368 | |
| 2369 /************************************************************************/ | |
| 2370 /* the workhorse error-signaling function */ | |
| 2371 /************************************************************************/ | |
| 2372 | |
| 853 | 2373 /* This exists only for debugging purposes, as a place to put a breakpoint |
| 2374 that won't get signalled for errors occurring when | |
| 2375 call_with_suspended_errors() was invoked. */ | |
| 2376 | |
| 872 | 2377 /* Don't make static or it might be compiled away */ |
| 2378 void signal_1 (void); | |
| 2379 | |
| 2380 void | |
| 853 | 2381 signal_1 (void) |
| 2382 { | |
| 2383 } | |
| 2384 | |
| 428 | 2385 /* #### This function has not been synched with FSF. It diverges |
| 2386 significantly. */ | |
| 2387 | |
| 853 | 2388 /* The simplest external error function: it would be called |
| 2389 signal_continuable_error() in the terminology below, but it's | |
| 2390 Lisp-callable. */ | |
| 2391 | |
| 2392 DEFUN ("signal", Fsignal, 2, 2, 0, /* | |
| 2393 Signal a continuable error. Args are ERROR-SYMBOL, and associated DATA. | |
| 2394 An error symbol is a symbol defined using `define-error'. | |
| 2395 DATA should be a list. Its elements are printed as part of the error message. | |
| 2396 If the signal is handled, DATA is made available to the handler. | |
| 2397 See also the function `signal-error', and the functions to handle errors: | |
| 2398 `condition-case' and `call-with-condition-handler'. | |
| 2399 | |
| 2400 Note that this function can return, if the debugger is invoked and the | |
| 2401 user invokes the "return from signal" option. | |
| 2402 */ | |
| 2403 (error_symbol, data)) | |
| 428 | 2404 { |
| 2405 /* This function can GC */ | |
| 853 | 2406 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; |
| 2407 Lisp_Object conditions = Qnil; | |
| 2408 Lisp_Object handlers = Qnil; | |
| 428 | 2409 /* signal_call_debugger() could get called more than once |
| 2410 (once when a call-with-condition-handler is about to | |
| 2411 be dealt with, and another when a condition-case handler | |
| 2412 is about to be invoked). So make sure the debugger and/or | |
| 2413 stack trace aren't done more than once. */ | |
| 2414 int stack_trace_displayed = 0; | |
| 2415 int debugger_entered = 0; | |
| 853 | 2416 |
| 2417 /* Fsignal() is one of these functions that's called all the time | |
| 2418 with newly-created Lisp objects. We allow this; but we must GC- | |
| 2419 protect the objects because all sorts of weird stuff could | |
| 2420 happen. */ | |
| 2421 | |
| 2422 GCPRO4 (conditions, handlers, error_symbol, data); | |
| 2423 | |
| 2424 if (!(inhibit_flags & CALL_WITH_SUSPENDED_ERRORS)) | |
| 2425 signal_1 (); | |
| 428 | 2426 |
| 2427 if (!initialized) | |
| 2428 { | |
| 2429 /* who knows how much has been initialized? Safest bet is | |
| 2430 just to bomb out immediately. */ | |
| 771 | 2431 stderr_out ("Error before initialization is complete!\n"); |
| 2500 | 2432 ABORT (); |
| 428 | 2433 } |
| 2434 | |
| 3092 | 2435 #ifndef NEW_GC |
| 1123 | 2436 assert (!gc_in_progress); |
| 3092 | 2437 #endif /* not NEW_GC */ |
| 1123 | 2438 |
| 2439 /* We abort if in_display and we are not protected, as garbage | |
| 2440 collections and non-local exits will invariably be fatal, but in | |
| 2441 messy, difficult-to-debug ways. See enter_redisplay_critical_section(). | |
| 2442 */ | |
| 2443 | |
| 1318 | 2444 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1123 | 2445 check_proper_critical_section_nonlocal_exit_protection (); |
| 1318 | 2446 #endif |
| 428 | 2447 |
| 853 | 2448 conditions = Fget (error_symbol, Qerror_conditions, Qnil); |
| 428 | 2449 |
| 2450 for (handlers = Vcondition_handlers; | |
| 2451 CONSP (handlers); | |
| 2452 handlers = XCDR (handlers)) | |
| 2453 { | |
| 2454 Lisp_Object handler_fun = XCAR (XCAR (handlers)); | |
| 2455 Lisp_Object handler_data = XCDR (XCAR (handlers)); | |
| 2456 Lisp_Object outer_handlers = XCDR (handlers); | |
| 2457 | |
| 2458 if (!UNBOUNDP (handler_fun)) | |
| 2459 { | |
| 2460 /* call-with-condition-handler */ | |
| 2461 Lisp_Object tem; | |
| 2462 Lisp_Object all_handlers = Vcondition_handlers; | |
| 2463 struct gcpro ngcpro1; | |
| 2464 NGCPRO1 (all_handlers); | |
| 2465 Vcondition_handlers = outer_handlers; | |
| 2466 | |
| 853 | 2467 tem = signal_call_debugger (conditions, error_symbol, data, |
| 428 | 2468 outer_handlers, 1, |
| 2469 &stack_trace_displayed, | |
| 2470 &debugger_entered); | |
| 2471 if (!UNBOUNDP (tem)) | |
| 2472 RETURN_NUNGCPRO (return_from_signal (tem)); | |
| 2473 | |
| 853 | 2474 if (OPAQUE_PTRP (handler_fun)) |
| 2475 { | |
| 2476 if (NILP (handler_data)) | |
| 2477 { | |
| 2478 Lisp_Object (*hfun) (Lisp_Object, Lisp_Object) = | |
| 2479 (Lisp_Object (*) (Lisp_Object, Lisp_Object)) | |
| 2480 (get_opaque_ptr (handler_fun)); | |
| 2481 | |
| 2482 tem = (*hfun) (error_symbol, data); | |
| 2483 } | |
| 2484 else | |
| 2485 { | |
| 2486 Lisp_Object (*hfun) (Lisp_Object, Lisp_Object, Lisp_Object) = | |
| 2487 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object)) | |
| 2488 (get_opaque_ptr (handler_fun)); | |
| 2489 | |
| 2490 assert (NILP (XCDR (handler_data))); | |
| 2491 tem = (*hfun) (error_symbol, data, XCAR (handler_data)); | |
| 2492 } | |
| 2493 } | |
| 2494 else | |
| 2495 { | |
| 2496 tem = Fcons (error_symbol, data); | |
| 2497 if (NILP (handler_data)) | |
| 2498 tem = call1 (handler_fun, tem); | |
| 2499 else | |
| 2500 { | |
| 2501 /* (This code won't be used (for now?).) */ | |
| 2502 struct gcpro nngcpro1; | |
| 2503 Lisp_Object args[3]; | |
| 2504 NNGCPRO1 (args[0]); | |
| 2505 nngcpro1.nvars = 3; | |
| 2506 args[0] = handler_fun; | |
| 2507 args[1] = tem; | |
| 2508 args[2] = handler_data; | |
| 2509 nngcpro1.var = args; | |
| 2510 tem = Fapply (3, args); | |
| 2511 NNUNGCPRO; | |
| 2512 } | |
| 2513 } | |
| 428 | 2514 NUNGCPRO; |
| 2515 #if 0 | |
| 2516 if (!EQ (tem, Qsignal)) | |
| 2517 return return_from_signal (tem); | |
| 2518 #endif | |
| 2519 /* If handler didn't throw, try another handler */ | |
| 2520 Vcondition_handlers = all_handlers; | |
| 2521 } | |
| 2522 | |
| 2523 /* It's a condition-case handler */ | |
| 2524 | |
| 2525 /* t is used by handlers for all conditions, set up by C code. | |
| 2526 * debugger is not called even if debug_on_error */ | |
| 2527 else if (EQ (handler_data, Qt)) | |
| 2528 { | |
| 2529 UNGCPRO; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2530 throw_or_bomb_out (handlers, Fcons (error_symbol, data), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2531 0, Qnil, Qnil); |
| 428 | 2532 } |
| 2533 /* `error' is used similarly to the way `t' is used, but in | |
| 2534 addition it invokes the debugger if debug_on_error. | |
| 2535 This is normally used for the outer command-loop error | |
| 2536 handler. */ | |
| 2537 else if (EQ (handler_data, Qerror)) | |
| 2538 { | |
| 853 | 2539 Lisp_Object tem = signal_call_debugger (conditions, error_symbol, |
| 2540 data, | |
| 428 | 2541 outer_handlers, 0, |
| 2542 &stack_trace_displayed, | |
| 2543 &debugger_entered); | |
| 2544 | |
| 2545 UNGCPRO; | |
| 2546 if (!UNBOUNDP (tem)) | |
| 2547 return return_from_signal (tem); | |
| 2548 | |
| 853 | 2549 tem = Fcons (error_symbol, data); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2550 throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); |
| 428 | 2551 } |
| 2552 else | |
| 2553 { | |
| 2554 /* handler established by real (Lisp) condition-case */ | |
| 2555 Lisp_Object h; | |
| 2556 | |
| 2557 for (h = handler_data; CONSP (h); h = Fcdr (h)) | |
| 2558 { | |
| 2559 Lisp_Object clause = Fcar (h); | |
| 2560 Lisp_Object tem = Fcar (clause); | |
| 2561 | |
| 2562 if (condition_type_p (tem, conditions)) | |
| 2563 { | |
| 853 | 2564 tem = signal_call_debugger (conditions, error_symbol, data, |
| 428 | 2565 outer_handlers, 1, |
| 2566 &stack_trace_displayed, | |
| 2567 &debugger_entered); | |
| 2568 UNGCPRO; | |
| 2569 if (!UNBOUNDP (tem)) | |
| 2570 return return_from_signal (tem); | |
| 2571 | |
| 2572 /* Doesn't return */ | |
| 853 | 2573 tem = Fcons (Fcons (error_symbol, data), Fcdr (clause)); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2574 throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); |
| 428 | 2575 } |
| 2576 } | |
| 2577 } | |
| 2578 } | |
| 2579 | |
| 2580 /* If no handler is present now, try to run the debugger, | |
| 2581 and if that fails, throw to top level. | |
| 2582 | |
| 2583 #### The only time that no handler is present is during | |
| 2584 temacs or perhaps very early in XEmacs. In both cases, | |
| 3025 | 2585 there is no `top-level' catch. (That's why the |
| 428 | 2586 "bomb-out" hack was added.) |
| 2587 | |
| 853 | 2588 [[#### Fix this horrifitude!]] |
| 2589 | |
| 2590 I don't think this is horrifitude, but just defensive coding. --ben */ | |
| 2591 | |
| 2592 signal_call_debugger (conditions, error_symbol, data, Qnil, 0, | |
| 428 | 2593 &stack_trace_displayed, |
| 2594 &debugger_entered); | |
| 2595 UNGCPRO; | |
| 853 | 2596 throw_or_bomb_out (Qtop_level, Qt, 1, error_symbol, |
| 2597 data); /* Doesn't return */ | |
| 2268 | 2598 RETURN_NOT_REACHED (Qnil); |
| 428 | 2599 } |
| 2600 | |
| 2601 /****************** Error functions class 1 ******************/ | |
| 2602 | |
| 2603 /* Class 1: General functions that signal an error. | |
| 2604 These functions take an error type and a list of associated error | |
| 2605 data. */ | |
| 2606 | |
| 853 | 2607 /* No signal_continuable_error_1(); it's called Fsignal(). */ |
| 428 | 2608 |
| 2609 /* Signal a non-continuable error. */ | |
| 2610 | |
| 2611 DOESNT_RETURN | |
| 563 | 2612 signal_error_1 (Lisp_Object sig, Lisp_Object data) |
| 428 | 2613 { |
| 2614 for (;;) | |
| 2615 Fsignal (sig, data); | |
| 2616 } | |
| 853 | 2617 |
| 2618 #ifdef ERROR_CHECK_CATCH | |
| 2619 | |
| 2620 void | |
| 2621 check_catchlist_sanity (void) | |
| 2622 { | |
| 2623 #if 0 | |
| 2624 /* vou me tomar no cu! i just masked andy's missing-unbind | |
| 2625 bug! */ | |
| 442 | 2626 struct catchtag *c; |
| 2627 int found_error_tag = 0; | |
| 2628 | |
| 2629 for (c = catchlist; c; c = c->next) | |
| 2630 { | |
| 2631 if (EQ (c->tag, Qunbound_suspended_errors_tag)) | |
| 2632 { | |
| 2633 found_error_tag = 1; | |
| 2634 break; | |
| 2635 } | |
| 2636 } | |
| 2637 | |
| 2638 assert (found_error_tag || NILP (Vcurrent_error_state)); | |
| 853 | 2639 #endif /* vou me tomar no cul */ |
| 2640 } | |
| 2641 | |
| 2642 void | |
| 2643 check_specbind_stack_sanity (void) | |
| 2644 { | |
| 2645 } | |
| 2646 | |
| 2647 #endif /* ERROR_CHECK_CATCH */ | |
| 428 | 2648 |
| 2649 /* Signal a non-continuable error or display a warning or do nothing, | |
| 2650 according to ERRB. CLASS is the class of warning and should | |
| 2651 refer to what sort of operation is being done (e.g. Qtoolbar, | |
| 2652 Qresource, etc.). */ | |
| 2653 | |
| 2654 void | |
| 1204 | 2655 maybe_signal_error_1 (Lisp_Object sig, Lisp_Object data, Lisp_Object class_, |
| 578 | 2656 Error_Behavior errb) |
| 428 | 2657 { |
| 2658 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2659 return; | |
| 793 | 2660 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) |
| 1204 | 2661 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data)); |
| 428 | 2662 else if (ERRB_EQ (errb, ERROR_ME_WARN)) |
| 1204 | 2663 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data)); |
| 428 | 2664 else |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2665 signal_error_1 (sig, data); |
| 428 | 2666 } |
| 2667 | |
| 2668 /* Signal a continuable error or display a warning or do nothing, | |
| 2669 according to ERRB. */ | |
| 2670 | |
| 2671 Lisp_Object | |
| 563 | 2672 maybe_signal_continuable_error_1 (Lisp_Object sig, Lisp_Object data, |
| 1204 | 2673 Lisp_Object class_, Error_Behavior errb) |
| 428 | 2674 { |
| 2675 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2676 return Qnil; | |
| 793 | 2677 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) |
| 2678 { | |
| 1204 | 2679 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data)); |
| 793 | 2680 return Qnil; |
| 2681 } | |
| 428 | 2682 else if (ERRB_EQ (errb, ERROR_ME_WARN)) |
| 2683 { | |
| 1204 | 2684 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data)); |
| 428 | 2685 return Qnil; |
| 2686 } | |
| 2687 else | |
| 2688 return Fsignal (sig, data); | |
| 2689 } | |
| 2690 | |
| 2691 | |
| 2692 /****************** Error functions class 2 ******************/ | |
| 2693 | |
| 563 | 2694 /* Class 2: Signal an error with a string and an associated object. |
| 2695 Normally these functions are used to attach one associated object, | |
| 2696 but to attach no objects, specify Qunbound for FROB, and for more | |
| 2697 than one object, make a list of the objects with Qunbound as the | |
| 2698 first element. (If you have specifically two objects to attach, | |
| 2699 consider using the function in class 3 below.) These functions | |
| 2700 signal an error of a specified type, whose data is one or more | |
| 2701 objects (usually two), a string the related Lisp object(s) | |
| 2702 specified as FROB. */ | |
| 2703 | |
| 2704 /* Out of REASON and FROB, return a list of elements suitable for passing | |
| 2705 to signal_error_1(). */ | |
| 2706 | |
| 2707 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2708 build_error_data (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 2709 { |
| 2710 if (EQ (frob, Qunbound)) | |
| 2711 frob = Qnil; | |
| 2712 else if (CONSP (frob) && EQ (XCAR (frob), Qunbound)) | |
| 2713 frob = XCDR (frob); | |
| 2714 else | |
| 2715 frob = list1 (frob); | |
| 2716 if (!reason) | |
| 2717 return frob; | |
| 2718 else | |
| 771 | 2719 return Fcons (build_msg_string (reason), frob); |
| 563 | 2720 } |
| 2721 | |
| 2722 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2723 signal_error (Lisp_Object type, const Ascbyte *reason, Lisp_Object frob) |
| 563 | 2724 { |
| 2725 signal_error_1 (type, build_error_data (reason, frob)); | |
| 2726 } | |
| 2727 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2728 /* NOTE NOTE NOTE: If you feel you need signal_ierror() or something |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2729 similar when reason is a non-ASCII message, you're probably doing |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2730 something wrong. When you have an error message from an external |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2731 source, you should put the error message as the first item in FROB and |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2732 put a string in REASON indicating what you were doing when the error |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2733 message occurred. Use signal_error_2() for such a case. */ |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2734 |
| 563 | 2735 void |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2736 maybe_signal_error (Lisp_Object type, const Ascbyte *reason, |
| 1204 | 2737 Lisp_Object frob, Lisp_Object class_, |
| 578 | 2738 Error_Behavior errb) |
| 563 | 2739 { |
| 2740 /* Optimization: */ | |
| 2741 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2742 return; | |
| 1204 | 2743 maybe_signal_error_1 (type, build_error_data (reason, frob), class_, errb); |
| 563 | 2744 } |
| 2745 | |
| 2746 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2747 signal_continuable_error (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2748 Lisp_Object frob) |
| 2749 { | |
| 2750 return Fsignal (type, build_error_data (reason, frob)); | |
| 2751 } | |
| 2752 | |
| 2753 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2754 maybe_signal_continuable_error (Lisp_Object type, const Ascbyte *reason, |
| 1204 | 2755 Lisp_Object frob, Lisp_Object class_, |
| 578 | 2756 Error_Behavior errb) |
| 563 | 2757 { |
| 2758 /* Optimization: */ | |
| 2759 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2760 return Qnil; | |
| 2761 return maybe_signal_continuable_error_1 (type, | |
| 2762 build_error_data (reason, frob), | |
| 1204 | 2763 class_, errb); |
| 563 | 2764 } |
| 2765 | |
| 2766 | |
| 2767 /****************** Error functions class 3 ******************/ | |
| 2768 | |
| 2769 /* Class 3: Signal an error with a string and two associated objects. | |
| 2770 These functions signal an error of a specified type, whose data | |
| 2771 is three objects, a string and two related Lisp objects. | |
| 2772 (The equivalent could be accomplished using the class 2 functions, | |
| 2773 but these are more convenient in this particular case.) */ | |
| 2774 | |
| 2775 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2776 signal_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2777 Lisp_Object frob0, Lisp_Object frob1) |
| 2778 { | |
| 771 | 2779 signal_error_1 (type, list3 (build_msg_string (reason), frob0, |
| 563 | 2780 frob1)); |
| 2781 } | |
| 2782 | |
| 2783 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2784 maybe_signal_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2785 Lisp_Object frob0, Lisp_Object frob1, |
| 1204 | 2786 Lisp_Object class_, Error_Behavior errb) |
| 563 | 2787 { |
| 2788 /* Optimization: */ | |
| 2789 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2790 return; | |
| 771 | 2791 maybe_signal_error_1 (type, list3 (build_msg_string (reason), frob0, |
| 1204 | 2792 frob1), class_, errb); |
| 563 | 2793 } |
| 2794 | |
| 2795 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2796 signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2797 Lisp_Object frob0, Lisp_Object frob1) |
| 2798 { | |
| 771 | 2799 return Fsignal (type, list3 (build_msg_string (reason), frob0, |
| 563 | 2800 frob1)); |
| 2801 } | |
| 2802 | |
| 2803 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2804 maybe_signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2805 Lisp_Object frob0, Lisp_Object frob1, |
| 1204 | 2806 Lisp_Object class_, Error_Behavior errb) |
| 563 | 2807 { |
| 2808 /* Optimization: */ | |
| 2809 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2810 return Qnil; | |
| 2811 return maybe_signal_continuable_error_1 | |
| 771 | 2812 (type, list3 (build_msg_string (reason), frob0, frob1), |
| 1204 | 2813 class_, errb); |
| 563 | 2814 } |
| 2815 | |
| 2816 | |
| 2817 /****************** Error functions class 4 ******************/ | |
| 2818 | |
| 2819 /* Class 4: Printf-like functions that signal an error. | |
| 442 | 2820 These functions signal an error of a specified type, whose data |
| 428 | 2821 is a single string, created using the arguments. */ |
| 2822 | |
| 2823 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2824 signal_ferror (Lisp_Object type, const Ascbyte *fmt, ...) |
| 442 | 2825 { |
| 2826 Lisp_Object obj; | |
| 2827 va_list args; | |
| 2828 | |
| 2829 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2830 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2831 va_end (args); |
| 2832 | |
| 2833 /* Fsignal GC-protects its args */ | |
| 563 | 2834 signal_error (type, 0, obj); |
| 442 | 2835 } |
| 2836 | |
| 2837 void | |
| 1204 | 2838 maybe_signal_ferror (Lisp_Object type, Lisp_Object class_, Error_Behavior errb, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2839 const Ascbyte *fmt, ...) |
| 442 | 2840 { |
| 2841 Lisp_Object obj; | |
| 2842 va_list args; | |
| 2843 | |
| 2844 /* Optimization: */ | |
| 2845 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2846 return; | |
| 2847 | |
| 2848 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2849 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2850 va_end (args); |
| 2851 | |
| 2852 /* Fsignal GC-protects its args */ | |
| 1204 | 2853 maybe_signal_error (type, 0, obj, class_, errb); |
| 442 | 2854 } |
| 2855 | |
| 2856 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2857 signal_continuable_ferror (Lisp_Object type, const Ascbyte *fmt, ...) |
| 428 | 2858 { |
| 2859 Lisp_Object obj; | |
| 2860 va_list args; | |
| 2861 | |
| 2862 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2863 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2864 va_end (args); |
| 2865 | |
| 2866 /* Fsignal GC-protects its args */ | |
| 2867 return Fsignal (type, list1 (obj)); | |
| 2868 } | |
| 2869 | |
| 2870 Lisp_Object | |
| 1204 | 2871 maybe_signal_continuable_ferror (Lisp_Object type, Lisp_Object class_, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2872 Error_Behavior errb, const Ascbyte *fmt, ...) |
| 442 | 2873 { |
| 2874 Lisp_Object obj; | |
| 2875 va_list args; | |
| 2876 | |
| 2877 /* Optimization: */ | |
| 2878 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2879 return Qnil; | |
| 2880 | |
| 2881 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2882 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2883 va_end (args); |
| 2884 | |
| 2885 /* Fsignal GC-protects its args */ | |
| 1204 | 2886 return maybe_signal_continuable_error (type, 0, obj, class_, errb); |
| 442 | 2887 } |
| 2888 | |
| 2889 | |
| 2890 /****************** Error functions class 5 ******************/ | |
| 2891 | |
| 563 | 2892 /* Class 5: Printf-like functions that signal an error. |
| 442 | 2893 These functions signal an error of a specified type, whose data |
| 563 | 2894 is a one or more objects, a string (created using the arguments) |
| 2895 and additional Lisp objects specified in FROB. (The syntax of FROB | |
| 2896 is the same as for class 2.) | |
| 2897 | |
| 2898 There is no need for a class 6 because you can always attach 2 | |
| 2899 objects using class 5 (for FROB, specify a list with three | |
| 2900 elements, the first of which is Qunbound), and these functions are | |
| 2901 not commonly used. | |
| 2902 */ | |
| 442 | 2903 |
| 2904 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2905 signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, const Ascbyte *fmt, |
| 563 | 2906 ...) |
| 442 | 2907 { |
| 2908 Lisp_Object obj; | |
| 2909 va_list args; | |
| 2910 | |
| 2911 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2912 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2913 va_end (args); |
| 2914 | |
| 2915 /* Fsignal GC-protects its args */ | |
| 563 | 2916 signal_error_1 (type, Fcons (obj, build_error_data (0, frob))); |
| 442 | 2917 } |
| 2918 | |
| 2919 void | |
| 563 | 2920 maybe_signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
| 1204 | 2921 Lisp_Object class_, Error_Behavior errb, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2922 const Ascbyte *fmt, ...) |
| 442 | 2923 { |
| 2924 Lisp_Object obj; | |
| 2925 va_list args; | |
| 2926 | |
| 2927 /* Optimization: */ | |
| 2928 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2929 return; | |
| 2930 | |
| 2931 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2932 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 2933 va_end (args); |
| 2934 | |
| 2935 /* Fsignal GC-protects its args */ | |
| 1204 | 2936 maybe_signal_error_1 (type, Fcons (obj, build_error_data (0, frob)), class_, |
| 563 | 2937 errb); |
| 428 | 2938 } |
| 2939 | |
| 2940 Lisp_Object | |
| 563 | 2941 signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2942 const Ascbyte *fmt, ...) |
| 428 | 2943 { |
| 2944 Lisp_Object obj; | |
| 2945 va_list args; | |
| 2946 | |
| 2947 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2948 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 2949 va_end (args); |
| 2950 | |
| 2951 /* Fsignal GC-protects its args */ | |
| 563 | 2952 return Fsignal (type, Fcons (obj, build_error_data (0, frob))); |
| 428 | 2953 } |
| 2954 | |
| 2955 Lisp_Object | |
| 563 | 2956 maybe_signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
| 1204 | 2957 Lisp_Object class_, |
| 578 | 2958 Error_Behavior errb, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2959 const Ascbyte *fmt, ...) |
| 428 | 2960 { |
| 2961 Lisp_Object obj; | |
| 2962 va_list args; | |
| 2963 | |
| 2964 /* Optimization: */ | |
| 2965 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2966 return Qnil; | |
| 2967 | |
| 2968 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2969 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 2970 va_end (args); |
| 2971 | |
| 2972 /* Fsignal GC-protects its args */ | |
| 563 | 2973 return maybe_signal_continuable_error_1 (type, |
| 2974 Fcons (obj, | |
| 2975 build_error_data (0, frob)), | |
| 1204 | 2976 class_, errb); |
| 428 | 2977 } |
| 2978 | |
| 2979 | |
| 2980 /* This is what the QUIT macro calls to signal a quit */ | |
| 2981 void | |
| 2982 signal_quit (void) | |
| 2983 { | |
| 853 | 2984 /* This function cannot GC. GC is prohibited because most callers do |
| 2985 not expect GC occurring in QUIT. Remove this if/when that gets fixed. | |
| 2986 --ben */ | |
| 2987 | |
| 2988 int count; | |
| 2989 | |
| 428 | 2990 if (EQ (Vquit_flag, Qcritical)) |
| 2991 debug_on_quit |= 2; /* set critical bit. */ | |
| 2992 Vquit_flag = Qnil; | |
| 853 | 2993 count = begin_gc_forbidden (); |
| 428 | 2994 /* note that this is continuable. */ |
| 2995 Fsignal (Qquit, Qnil); | |
| 853 | 2996 unbind_to (count); |
| 428 | 2997 } |
| 2998 | |
| 2999 | |
| 563 | 3000 /************************ convenience error functions ***********************/ |
| 3001 | |
| 436 | 3002 Lisp_Object |
| 428 | 3003 signal_void_function_error (Lisp_Object function) |
| 3004 { | |
| 436 | 3005 return Fsignal (Qvoid_function, list1 (function)); |
| 428 | 3006 } |
| 3007 | |
| 436 | 3008 Lisp_Object |
| 428 | 3009 signal_invalid_function_error (Lisp_Object function) |
| 3010 { | |
| 436 | 3011 return Fsignal (Qinvalid_function, list1 (function)); |
| 428 | 3012 } |
| 3013 | |
| 436 | 3014 Lisp_Object |
| 428 | 3015 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs) |
| 3016 { | |
| 436 | 3017 return Fsignal (Qwrong_number_of_arguments, |
| 3018 list2 (function, make_int (nargs))); | |
| 428 | 3019 } |
| 3020 | |
| 3021 /* Used in list traversal macros for efficiency. */ | |
| 436 | 3022 DOESNT_RETURN |
| 428 | 3023 signal_malformed_list_error (Lisp_Object list) |
| 3024 { | |
| 563 | 3025 signal_error (Qmalformed_list, 0, list); |
| 428 | 3026 } |
| 3027 | |
| 436 | 3028 DOESNT_RETURN |
| 428 | 3029 signal_malformed_property_list_error (Lisp_Object list) |
| 3030 { | |
| 563 | 3031 signal_error (Qmalformed_property_list, 0, list); |
| 428 | 3032 } |
| 3033 | |
| 436 | 3034 DOESNT_RETURN |
| 428 | 3035 signal_circular_list_error (Lisp_Object list) |
| 3036 { | |
| 563 | 3037 signal_error (Qcircular_list, 0, list); |
| 428 | 3038 } |
| 3039 | |
| 436 | 3040 DOESNT_RETURN |
| 428 | 3041 signal_circular_property_list_error (Lisp_Object list) |
| 3042 { | |
| 563 | 3043 signal_error (Qcircular_property_list, 0, list); |
| 428 | 3044 } |
| 442 | 3045 |
| 2267 | 3046 /* Called from within emacs_doprnt_1, so REASON is not formatted. */ |
| 442 | 3047 DOESNT_RETURN |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3048 syntax_error (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3049 { |
| 563 | 3050 signal_error (Qsyntax_error, reason, frob); |
| 442 | 3051 } |
| 3052 | |
| 3053 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3054 syntax_error_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 442 | 3055 { |
| 563 | 3056 signal_error_2 (Qsyntax_error, reason, frob1, frob2); |
| 3057 } | |
| 3058 | |
| 3059 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3060 maybe_syntax_error (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3061 Lisp_Object class_, Error_Behavior errb) |
| 3062 { | |
| 3063 maybe_signal_error (Qsyntax_error, reason, frob, class_, errb); | |
| 563 | 3064 } |
| 3065 | |
| 3066 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3067 sferror (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3068 { |
| 3069 signal_error (Qstructure_formation_error, reason, frob); | |
| 3070 } | |
| 3071 | |
| 3072 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3073 sferror_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 563 | 3074 { |
| 3075 signal_error_2 (Qstructure_formation_error, reason, frob1, frob2); | |
| 3076 } | |
| 3077 | |
| 3078 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3079 maybe_sferror (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3080 Lisp_Object class_, Error_Behavior errb) |
| 3081 { | |
| 3082 maybe_signal_error (Qstructure_formation_error, reason, frob, class_, errb); | |
| 442 | 3083 } |
| 3084 | |
| 3085 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3086 invalid_argument (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3087 { |
| 563 | 3088 signal_error (Qinvalid_argument, reason, frob); |
| 442 | 3089 } |
| 3090 | |
| 3091 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3092 invalid_argument_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3093 Lisp_Object frob2) |
| 442 | 3094 { |
| 563 | 3095 signal_error_2 (Qinvalid_argument, reason, frob1, frob2); |
| 3096 } | |
| 3097 | |
| 3098 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3099 maybe_invalid_argument (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3100 Lisp_Object class_, Error_Behavior errb) |
| 3101 { | |
| 3102 maybe_signal_error (Qinvalid_argument, reason, frob, class_, errb); | |
| 563 | 3103 } |
| 3104 | |
| 3105 DOESNT_RETURN | |
|
5084
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3106 invalid_keyword_argument (Lisp_Object function, Lisp_Object keyword) |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3107 { |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3108 signal_error_1 (Qinvalid_keyword_argument, list2 (function, keyword)); |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3109 } |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3110 |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3111 DOESNT_RETURN |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3112 invalid_constant (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3113 { |
| 3114 signal_error (Qinvalid_constant, reason, frob); | |
| 3115 } | |
| 3116 | |
| 3117 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3118 invalid_constant_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3119 Lisp_Object frob2) |
| 563 | 3120 { |
| 3121 signal_error_2 (Qinvalid_constant, reason, frob1, frob2); | |
| 3122 } | |
| 3123 | |
| 3124 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3125 maybe_invalid_constant (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3126 Lisp_Object class_, Error_Behavior errb) |
| 3127 { | |
| 3128 maybe_signal_error (Qinvalid_constant, reason, frob, class_, errb); | |
| 442 | 3129 } |
| 3130 | |
| 3131 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3132 invalid_operation (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3133 { |
| 563 | 3134 signal_error (Qinvalid_operation, reason, frob); |
| 442 | 3135 } |
| 3136 | |
| 3137 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3138 invalid_operation_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3139 Lisp_Object frob2) |
| 442 | 3140 { |
| 563 | 3141 signal_error_2 (Qinvalid_operation, reason, frob1, frob2); |
| 3142 } | |
| 3143 | |
| 3144 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3145 maybe_invalid_operation (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3146 Lisp_Object class_, Error_Behavior errb) |
| 3147 { | |
| 3148 maybe_signal_error (Qinvalid_operation, reason, frob, class_, errb); | |
| 442 | 3149 } |
| 3150 | |
| 3151 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3152 invalid_change (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3153 { |
| 563 | 3154 signal_error (Qinvalid_change, reason, frob); |
| 442 | 3155 } |
| 3156 | |
| 3157 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3158 invalid_change_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 442 | 3159 { |
| 563 | 3160 signal_error_2 (Qinvalid_change, reason, frob1, frob2); |
| 3161 } | |
| 3162 | |
| 3163 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3164 maybe_invalid_change (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3165 Lisp_Object class_, Error_Behavior errb) |
| 3166 { | |
| 3167 maybe_signal_error (Qinvalid_change, reason, frob, class_, errb); | |
| 563 | 3168 } |
| 3169 | |
| 3170 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3171 invalid_state (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3172 { |
| 3173 signal_error (Qinvalid_state, reason, frob); | |
| 3174 } | |
| 3175 | |
| 3176 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3177 invalid_state_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 563 | 3178 { |
| 3179 signal_error_2 (Qinvalid_state, reason, frob1, frob2); | |
| 3180 } | |
| 3181 | |
| 3182 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3183 maybe_invalid_state (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3184 Lisp_Object class_, Error_Behavior errb) |
| 3185 { | |
| 3186 maybe_signal_error (Qinvalid_state, reason, frob, class_, errb); | |
| 563 | 3187 } |
| 3188 | |
| 3189 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3190 wtaerror (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3191 { |
| 3192 signal_error (Qwrong_type_argument, reason, frob); | |
| 3193 } | |
| 3194 | |
| 3195 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3196 stack_overflow (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3197 { |
| 3198 signal_error (Qstack_overflow, reason, frob); | |
| 3199 } | |
| 3200 | |
| 3201 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3202 out_of_memory (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3203 { |
| 3204 signal_error (Qout_of_memory, reason, frob); | |
| 3205 } | |
| 3206 | |
| 428 | 3207 |
| 3208 /************************************************************************/ | |
| 3209 /* User commands */ | |
| 3210 /************************************************************************/ | |
| 3211 | |
| 3212 DEFUN ("commandp", Fcommandp, 1, 1, 0, /* | |
| 3213 Return t if FUNCTION makes provisions for interactive calling. | |
| 3214 This means it contains a description for how to read arguments to give it. | |
| 3215 The value is nil for an invalid function or a symbol with no function | |
| 3216 definition. | |
| 3217 | |
| 3218 Interactively callable functions include | |
| 3219 | |
| 3220 -- strings and vectors (treated as keyboard macros) | |
| 3221 -- lambda-expressions that contain a top-level call to `interactive' | |
| 3222 -- autoload definitions made by `autoload' with non-nil fourth argument | |
| 3223 (i.e. the interactive flag) | |
| 3224 -- compiled-function objects with a non-nil `compiled-function-interactive' | |
| 3225 value | |
| 3226 -- subrs (built-in functions) that are interactively callable | |
| 3227 | |
| 3228 Also, a symbol satisfies `commandp' if its function definition does so. | |
| 3229 */ | |
| 3230 (function)) | |
| 3231 { | |
| 3232 Lisp_Object fun = indirect_function (function, 0); | |
| 3233 | |
| 3234 if (COMPILED_FUNCTIONP (fun)) | |
| 3235 return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil; | |
| 3236 | |
| 3237 /* Lists may represent commands. */ | |
| 3238 if (CONSP (fun)) | |
| 3239 { | |
| 3240 Lisp_Object funcar = XCAR (fun); | |
| 3241 if (EQ (funcar, Qlambda)) | |
| 3242 return Fassq (Qinteractive, Fcdr (Fcdr (fun))); | |
| 3243 if (EQ (funcar, Qautoload)) | |
| 3244 return Fcar (Fcdr (Fcdr (Fcdr (fun)))); | |
| 3245 else | |
| 3246 return Qnil; | |
| 3247 } | |
| 3248 | |
| 3249 /* Emacs primitives are interactive if their DEFUN specifies an | |
| 3250 interactive spec. */ | |
| 3251 if (SUBRP (fun)) | |
| 3252 return XSUBR (fun)->prompt ? Qt : Qnil; | |
| 3253 | |
| 3254 /* Strings and vectors are keyboard macros. */ | |
| 3255 if (VECTORP (fun) || STRINGP (fun)) | |
| 3256 return Qt; | |
| 3257 | |
| 3258 /* Everything else (including Qunbound) is not a command. */ | |
| 3259 return Qnil; | |
| 3260 } | |
| 3261 | |
| 3262 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /* | |
| 3263 Execute CMD as an editor command. | |
| 3264 CMD must be an object that satisfies the `commandp' predicate. | |
| 3265 Optional second arg RECORD-FLAG is as in `call-interactively'. | |
| 3266 The argument KEYS specifies the value to use instead of (this-command-keys) | |
| 3267 when reading the arguments. | |
| 3268 */ | |
| 444 | 3269 (cmd, record_flag, keys)) |
| 428 | 3270 { |
| 3271 /* This function can GC */ | |
| 3272 Lisp_Object prefixarg; | |
| 3273 Lisp_Object final = cmd; | |
| 4162 | 3274 PROFILE_DECLARE(); |
| 428 | 3275 struct console *con = XCONSOLE (Vselected_console); |
| 3276 | |
| 3277 prefixarg = con->prefix_arg; | |
| 3278 con->prefix_arg = Qnil; | |
| 3279 Vcurrent_prefix_arg = prefixarg; | |
| 3280 debug_on_next_call = 0; /* #### from FSFmacs; correct? */ | |
| 3281 | |
| 3282 if (SYMBOLP (cmd) && !NILP (Fget (cmd, Qdisabled, Qnil))) | |
| 733 | 3283 return run_hook (Qdisabled_command_hook); |
| 428 | 3284 |
| 3285 for (;;) | |
| 3286 { | |
| 3287 final = indirect_function (cmd, 1); | |
| 3288 if (CONSP (final) && EQ (Fcar (final), Qautoload)) | |
| 970 | 3289 { |
| 3290 /* do_autoload GCPROs both arguments */ | |
| 3291 do_autoload (final, cmd); | |
| 3292 } | |
| 428 | 3293 else |
| 3294 break; | |
| 3295 } | |
| 3296 | |
| 3297 if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final)) | |
| 3298 { | |
| 3299 backtrace.function = &Qcall_interactively; | |
| 3300 backtrace.args = &cmd; | |
| 3301 backtrace.nargs = 1; | |
| 3302 backtrace.evalargs = 0; | |
| 1292 | 3303 backtrace.pdlcount = specpdl_depth (); |
| 428 | 3304 backtrace.debug_on_exit = 0; |
| 1292 | 3305 backtrace.function_being_called = 0; |
| 428 | 3306 PUSH_BACKTRACE (backtrace); |
| 3307 | |
| 1292 | 3308 PROFILE_ENTER_FUNCTION (); |
| 444 | 3309 final = Fcall_interactively (cmd, record_flag, keys); |
| 1292 | 3310 PROFILE_EXIT_FUNCTION (); |
| 428 | 3311 |
| 3312 POP_BACKTRACE (backtrace); | |
| 3313 return final; | |
| 3314 } | |
| 3315 else if (STRINGP (final) || VECTORP (final)) | |
| 3316 { | |
| 3317 return Fexecute_kbd_macro (final, prefixarg); | |
| 3318 } | |
| 3319 else | |
| 3320 { | |
| 3321 Fsignal (Qwrong_type_argument, | |
| 3322 Fcons (Qcommandp, | |
| 3323 (EQ (cmd, final) | |
| 3324 ? list1 (cmd) | |
| 3325 : list2 (cmd, final)))); | |
| 3326 return Qnil; | |
| 3327 } | |
| 3328 } | |
| 3329 | |
| 3330 DEFUN ("interactive-p", Finteractive_p, 0, 0, 0, /* | |
| 3331 Return t if function in which this appears was called interactively. | |
| 3332 This means that the function was called with call-interactively (which | |
| 3333 includes being called as the binding of a key) | |
| 3334 and input is currently coming from the keyboard (not in keyboard macro). | |
| 3335 */ | |
| 3336 ()) | |
| 3337 { | |
| 3338 REGISTER struct backtrace *btp; | |
| 3339 REGISTER Lisp_Object fun; | |
| 3340 | |
| 3341 if (!INTERACTIVE) | |
| 3342 return Qnil; | |
| 3343 | |
| 3344 /* Unless the object was compiled, skip the frame of interactive-p itself | |
| 3345 (if interpreted) or the frame of byte-code (if called from a compiled | |
| 3346 function). Note that *btp->function may be a symbol pointing at a | |
| 3347 compiled function. */ | |
| 3348 btp = backtrace_list; | |
| 3349 | |
| 3350 #if 0 /* FSFmacs */ | |
| 3351 | |
| 3352 /* #### FSFmacs does the following instead. I can't figure | |
| 3353 out which one is more correct. */ | |
| 3354 /* If this isn't a byte-compiled function, there may be a frame at | |
| 3355 the top for Finteractive_p itself. If so, skip it. */ | |
| 3356 fun = Findirect_function (*btp->function); | |
| 3357 if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p) | |
| 3358 btp = btp->next; | |
| 3359 | |
| 3360 /* If we're running an Emacs 18-style byte-compiled function, there | |
| 3361 may be a frame for Fbyte_code. Now, given the strictest | |
| 3362 definition, this function isn't really being called | |
| 3363 interactively, but because that's the way Emacs 18 always builds | |
| 3364 byte-compiled functions, we'll accept it for now. */ | |
| 3365 if (EQ (*btp->function, Qbyte_code)) | |
| 3366 btp = btp->next; | |
| 3367 | |
| 3368 /* If this isn't a byte-compiled function, then we may now be | |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
3369 looking at several frames for special operators. Skip past them. */ |
| 428 | 3370 while (btp && |
| 3371 btp->nargs == UNEVALLED) | |
| 3372 btp = btp->next; | |
| 3373 | |
| 3374 #else | |
| 3375 | |
| 3376 if (! (COMPILED_FUNCTIONP (Findirect_function (*btp->function)))) | |
| 3377 btp = btp->next; | |
| 3378 for (; | |
| 3379 btp && (btp->nargs == UNEVALLED | |
| 3380 || EQ (*btp->function, Qbyte_code)); | |
| 3381 btp = btp->next) | |
| 3382 {} | |
| 3383 /* btp now points at the frame of the innermost function | |
| 3384 that DOES eval its args. | |
| 3385 If it is a built-in function (such as load or eval-region) | |
| 3386 return nil. */ | |
| 3387 /* Beats me why this is necessary, but it is */ | |
| 3388 if (btp && EQ (*btp->function, Qcall_interactively)) | |
| 3389 return Qt; | |
| 3390 | |
| 3391 #endif | |
| 3392 | |
| 3393 fun = Findirect_function (*btp->function); | |
| 3394 if (SUBRP (fun)) | |
| 3395 return Qnil; | |
| 3396 /* btp points to the frame of a Lisp function that called interactive-p. | |
| 3397 Return t if that function was called interactively. */ | |
| 3398 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively)) | |
| 3399 return Qt; | |
| 3400 return Qnil; | |
| 3401 } | |
| 3402 | |
| 3403 | |
| 3404 /************************************************************************/ | |
| 3405 /* Autoloading */ | |
| 3406 /************************************************************************/ | |
| 3407 | |
| 3408 DEFUN ("autoload", Fautoload, 2, 5, 0, /* | |
| 444 | 3409 Define FUNCTION to autoload from FILENAME. |
| 3410 FUNCTION is a symbol; FILENAME is a file name string to pass to `load'. | |
| 3411 The remaining optional arguments provide additional info about the | |
| 3412 real definition. | |
| 3413 DOCSTRING is documentation for FUNCTION. | |
| 3414 INTERACTIVE, if non-nil, says FUNCTION can be called interactively. | |
| 3415 TYPE indicates the type of the object: | |
| 428 | 3416 nil or omitted says FUNCTION is a function, |
| 3417 `keymap' says FUNCTION is really a keymap, and | |
| 3418 `macro' or t says FUNCTION is really a macro. | |
| 444 | 3419 If FUNCTION already has a non-void function definition that is not an |
| 3420 autoload object, this function does nothing and returns nil. | |
| 428 | 3421 */ |
| 444 | 3422 (function, filename, docstring, interactive, type)) |
| 428 | 3423 { |
| 3424 /* This function can GC */ | |
| 3425 CHECK_SYMBOL (function); | |
| 444 | 3426 CHECK_STRING (filename); |
| 428 | 3427 |
| 3428 /* If function is defined and not as an autoload, don't override */ | |
| 3429 { | |
| 3430 Lisp_Object f = XSYMBOL (function)->function; | |
| 3431 if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload))) | |
| 3432 return Qnil; | |
| 3433 } | |
| 3434 | |
| 3435 if (purify_flag) | |
| 3436 { | |
| 3437 /* Attempt to avoid consing identical (string=) pure strings. */ | |
| 444 | 3438 filename = Fsymbol_name (Fintern (filename, Qnil)); |
| 428 | 3439 } |
| 440 | 3440 |
| 444 | 3441 return Ffset (function, Fcons (Qautoload, list4 (filename, |
| 428 | 3442 docstring, |
| 3443 interactive, | |
| 3444 type))); | |
| 3445 } | |
| 3446 | |
| 3447 Lisp_Object | |
| 3448 un_autoload (Lisp_Object oldqueue) | |
| 3449 { | |
| 3450 /* This function can GC */ | |
| 3451 REGISTER Lisp_Object queue, first, second; | |
| 3452 | |
| 3453 /* Queue to unwind is current value of Vautoload_queue. | |
| 3454 oldqueue is the shadowed value to leave in Vautoload_queue. */ | |
| 3455 queue = Vautoload_queue; | |
| 3456 Vautoload_queue = oldqueue; | |
| 3457 while (CONSP (queue)) | |
| 3458 { | |
| 3459 first = XCAR (queue); | |
| 3460 second = Fcdr (first); | |
| 3461 first = Fcar (first); | |
| 3462 if (NILP (second)) | |
| 3463 Vfeatures = first; | |
| 3464 else | |
| 3465 Ffset (first, second); | |
| 3466 queue = Fcdr (queue); | |
| 3467 } | |
| 3468 return Qnil; | |
| 3469 } | |
| 3470 | |
| 970 | 3471 /* do_autoload GCPROs both arguments */ |
| 428 | 3472 void |
| 3473 do_autoload (Lisp_Object fundef, | |
| 3474 Lisp_Object funname) | |
| 3475 { | |
| 3476 /* This function can GC */ | |
| 3477 int speccount = specpdl_depth(); | |
| 3478 Lisp_Object fun = funname; | |
| 970 | 3479 struct gcpro gcpro1, gcpro2, gcpro3; |
| 428 | 3480 |
| 3481 CHECK_SYMBOL (funname); | |
| 970 | 3482 GCPRO3 (fundef, funname, fun); |
| 428 | 3483 |
| 3484 /* Value saved here is to be restored into Vautoload_queue */ | |
| 3485 record_unwind_protect (un_autoload, Vautoload_queue); | |
| 3486 Vautoload_queue = Qt; | |
| 3487 call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil); | |
| 3488 | |
| 3489 { | |
| 3490 Lisp_Object queue; | |
| 3491 | |
| 3492 /* Save the old autoloads, in case we ever do an unload. */ | |
| 3493 for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue)) | |
| 3494 { | |
| 3495 Lisp_Object first = XCAR (queue); | |
| 3496 Lisp_Object second = Fcdr (first); | |
| 3497 | |
| 3498 first = Fcar (first); | |
| 3499 | |
| 3500 /* Note: This test is subtle. The cdr of an autoload-queue entry | |
| 3501 may be an atom if the autoload entry was generated by a defalias | |
| 3502 or fset. */ | |
| 3503 if (CONSP (second)) | |
| 3504 Fput (first, Qautoload, (XCDR (second))); | |
| 3505 } | |
| 3506 } | |
| 3507 | |
| 3508 /* Once loading finishes, don't undo it. */ | |
| 3509 Vautoload_queue = Qt; | |
| 771 | 3510 unbind_to (speccount); |
| 428 | 3511 |
| 3512 fun = indirect_function (fun, 0); | |
| 3513 | |
| 3514 #if 0 /* FSFmacs */ | |
| 3515 if (!NILP (Fequal (fun, fundef))) | |
| 3516 #else | |
| 3517 if (UNBOUNDP (fun) | |
| 3518 || (CONSP (fun) | |
| 3519 && EQ (XCAR (fun), Qautoload))) | |
| 3520 #endif | |
| 563 | 3521 invalid_state ("Autoloading failed to define function", funname); |
| 428 | 3522 UNGCPRO; |
| 3523 } | |
| 3524 | |
| 3525 | |
| 3526 /************************************************************************/ | |
| 3527 /* eval, funcall, apply */ | |
| 3528 /************************************************************************/ | |
| 3529 | |
| 814 | 3530 /* NOTE: If you are hearing the endless complaint that function calls in |
| 3531 elisp are extremely slow, it just isn't true any more! The stuff below | |
| 3532 -- in particular, the calling of subrs and compiled functions, the most | |
| 3533 common cases -- has been highly optimized. There isn't a whole lot left | |
| 3534 to do to squeeze more speed out except by switching to lexical | |
| 3535 variables, which would eliminate the specbind loop. (But the real gain | |
| 3536 from lexical variables would come from better optimization -- with | |
| 3537 dynamic binding, you have the constant problem that any function call | |
| 3538 that you haven't explicitly proven to be side-effect-free might | |
| 3539 potentially side effect your local variables, which makes optimization | |
| 3540 extremely difficult when there are function calls anywhere in a chunk of | |
| 3541 code to be optimized. Even worse, you don't know that *your* local | |
| 3542 variables aren't side-effecting an outer function's local variables, so | |
| 3543 it's impossible to optimize away almost *any* variable assignment.) */ | |
| 3544 | |
| 428 | 3545 static Lisp_Object funcall_lambda (Lisp_Object fun, |
| 442 | 3546 int nargs, Lisp_Object args[]); |
| 428 | 3547 static int in_warnings; |
| 3548 | |
| 3549 | |
| 814 | 3550 void handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f, |
| 3551 int nargs, | |
| 3552 Lisp_Object args[]); | |
| 3553 | |
| 3554 /* The theory behind making this a separate function is to shrink | |
| 3555 funcall_compiled_function() so as to increase the likelihood of a cache | |
| 3556 hit in the L1 cache -- &rest processing is not going to be fast anyway. | |
| 3557 The idea is the same as with execute_rare_opcode() in bytecode.c. We | |
| 3558 make this non-static to ensure the compiler doesn't inline it. */ | |
| 3559 | |
| 3560 void | |
| 3561 handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f, int nargs, | |
| 3562 Lisp_Object args[]) | |
| 3563 { | |
| 3564 REGISTER int i = 0; | |
| 3565 int max_non_rest_args = f->args_in_array - 1; | |
| 3566 int bindargs = min (nargs, max_non_rest_args); | |
| 3567 | |
| 3568 for (i = 0; i < bindargs; i++) | |
| 3092 | 3569 #ifdef NEW_GC |
| 3570 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3571 args[i]); | |
| 3572 #else /* not NEW_GC */ | |
| 814 | 3573 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3574 #endif /* not NEW_GC */ |
| 814 | 3575 for (i = bindargs; i < max_non_rest_args; i++) |
| 3092 | 3576 #ifdef NEW_GC |
| 3577 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3578 Qnil); | |
| 3579 #else /* not NEW_GC */ | |
| 814 | 3580 SPECBIND_FAST_UNSAFE (f->args[i], Qnil); |
| 3092 | 3581 #endif /* not NEW_GC */ |
| 3582 #ifdef NEW_GC | |
| 3583 SPECBIND_FAST_UNSAFE | |
| 3584 (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[max_non_rest_args], | |
| 3585 nargs > max_non_rest_args ? | |
| 3586 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : | |
| 3587 Qnil); | |
| 3588 #else /* not NEW_GC */ | |
| 814 | 3589 SPECBIND_FAST_UNSAFE |
| 3590 (f->args[max_non_rest_args], | |
| 3591 nargs > max_non_rest_args ? | |
| 3592 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : | |
| 3593 Qnil); | |
| 3092 | 3594 #endif /* not NEW_GC */ |
| 814 | 3595 } |
| 3596 | |
| 3597 /* Apply compiled-function object FUN to the NARGS evaluated arguments | |
| 3598 in ARGS, and return the result of evaluation. */ | |
| 3599 inline static Lisp_Object | |
| 3600 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[]) | |
| 3601 { | |
| 3602 /* This function can GC */ | |
| 3603 int speccount = specpdl_depth(); | |
| 3604 REGISTER int i = 0; | |
| 3605 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); | |
| 3606 | |
| 3607 if (!OPAQUEP (f->instructions)) | |
| 3608 /* Lazily munge the instructions into a more efficient form */ | |
| 3609 optimize_compiled_function (fun); | |
| 3610 | |
| 3611 /* optimize_compiled_function() guaranteed that f->specpdl_depth is | |
| 3612 the required space on the specbinding stack for binding the args | |
| 3613 and local variables of fun. So just reserve it once. */ | |
| 3614 SPECPDL_RESERVE (f->specpdl_depth); | |
| 3615 | |
| 3616 if (nargs == f->max_args) /* Optimize for the common case -- no unspecified | |
| 3617 optional arguments. */ | |
| 3618 { | |
| 3619 #if 1 | |
| 3620 for (i = 0; i < nargs; i++) | |
| 3092 | 3621 #ifdef NEW_GC |
| 3622 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3623 args[i]); | |
| 3624 #else /* not NEW_GC */ | |
| 814 | 3625 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3626 #endif /* not NEW_GC */ |
| 814 | 3627 #else |
| 3628 /* Here's an alternate way to write the loop that tries to further | |
| 3629 optimize funcalls for functions with few arguments by partially | |
| 3630 unrolling the loop. It's not clear whether this is a win since it | |
| 3631 increases the size of the function and the possibility of L1 cache | |
| 3632 misses. (Microsoft VC++ 6 with /O2 /G5 generates 0x90 == 144 bytes | |
| 3633 per SPECBIND_FAST_UNSAFE().) Tests under VC++ 6, running the byte | |
| 3634 compiler repeatedly and looking at the total time, show very | |
| 3635 little difference between the simple loop above, the unrolled code | |
| 3636 below, and a "partly unrolled" solution with only cases 0-2 below | |
| 3637 instead of 0-4. Therefore, I'm keeping it at the simple loop | |
| 3638 because it's smaller. */ | |
| 3639 switch (nargs) | |
| 3640 { | |
| 3641 default: | |
| 3642 for (i = nargs - 1; i >= 4; i--) | |
| 3643 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); | |
| 3644 case 4: SPECBIND_FAST_UNSAFE (f->args[3], args[3]); | |
| 3645 case 3: SPECBIND_FAST_UNSAFE (f->args[2], args[2]); | |
| 3646 case 2: SPECBIND_FAST_UNSAFE (f->args[1], args[1]); | |
| 3647 case 1: SPECBIND_FAST_UNSAFE (f->args[0], args[0]); | |
| 3648 case 0: break; | |
| 3649 } | |
| 3650 #endif | |
| 3651 } | |
| 3652 else if (nargs < f->min_args) | |
| 3653 goto wrong_number_of_arguments; | |
| 3654 else if (nargs < f->max_args) | |
| 3655 { | |
| 3656 for (i = 0; i < nargs; i++) | |
| 3092 | 3657 #ifdef NEW_GC |
| 3658 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3659 args[i]); | |
| 3660 #else /* not NEW_GC */ | |
| 814 | 3661 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3662 #endif /* not NEW_GC */ |
| 814 | 3663 for (i = nargs; i < f->max_args; i++) |
| 3092 | 3664 #ifdef NEW_GC |
| 3665 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3666 Qnil); | |
| 3667 #else /* not NEW_GC */ | |
| 814 | 3668 SPECBIND_FAST_UNSAFE (f->args[i], Qnil); |
| 3092 | 3669 #endif /* not NEW_GC */ |
| 814 | 3670 } |
| 3671 else if (f->max_args == MANY) | |
| 3672 handle_compiled_function_with_and_rest (f, nargs, args); | |
| 3673 else | |
| 3674 { | |
| 3675 wrong_number_of_arguments: | |
| 3676 /* The actual printed compiled_function object is incomprehensible. | |
| 3677 Check the backtrace to see if we can get a more meaningful symbol. */ | |
| 3678 if (EQ (fun, indirect_function (*backtrace_list->function, 0))) | |
| 3679 fun = *backtrace_list->function; | |
| 3680 return Fsignal (Qwrong_number_of_arguments, | |
| 3681 list2 (fun, make_int (nargs))); | |
| 3682 } | |
| 3683 | |
| 3684 { | |
| 3685 Lisp_Object value = | |
| 3686 execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions), | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3687 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3688 XOPAQUE_SIZE (f->instructions) / |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3689 sizeof (Opbyte), |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3690 #endif |
| 814 | 3691 f->stack_depth, |
| 3692 XVECTOR_DATA (f->constants)); | |
| 3693 | |
| 3694 /* The attempt to optimize this by only unbinding variables failed | |
| 3695 because using buffer-local variables as function parameters | |
| 3696 leads to specpdl_ptr->func != 0 */ | |
| 3697 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */ | |
| 3698 UNBIND_TO_GCPRO (speccount, value); | |
| 3699 return value; | |
| 3700 } | |
| 3701 } | |
| 3702 | |
| 428 | 3703 DEFUN ("eval", Feval, 1, 1, 0, /* |
| 3704 Evaluate FORM and return its value. | |
| 3705 */ | |
| 3706 (form)) | |
| 3707 { | |
| 3708 /* This function can GC */ | |
| 3709 Lisp_Object fun, val, original_fun, original_args; | |
| 3710 int nargs; | |
| 4162 | 3711 PROFILE_DECLARE(); |
| 428 | 3712 |
| 1318 | 3713 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 3714 check_proper_critical_section_lisp_protection (); | |
| 3715 #endif | |
| 3716 | |
| 3989 | 3717 if (!CONSP (form)) |
| 3718 { | |
| 3719 if (SYMBOLP (form)) | |
| 3720 { | |
| 3721 return Fsymbol_value (form); | |
| 3722 } | |
| 3723 | |
| 3724 return form; | |
| 3725 } | |
| 3726 | |
| 428 | 3727 /* I think this is a pretty safe place to call Lisp code, don't you? */ |
| 853 | 3728 while (!in_warnings && !NILP (Vpending_warnings) |
| 3729 /* well, perhaps not so safe after all! */ | |
| 3730 && !(inhibit_flags & INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY)) | |
| 428 | 3731 { |
| 3732 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
| 1204 | 3733 Lisp_Object this_warning_cons, this_warning, class_, level, messij; |
| 853 | 3734 int speccount = internal_bind_int (&in_warnings, 1); |
| 3735 | |
| 428 | 3736 this_warning_cons = Vpending_warnings; |
| 3737 this_warning = XCAR (this_warning_cons); | |
| 3738 /* in case an error occurs in the warn function, at least | |
| 3739 it won't happen infinitely */ | |
| 3740 Vpending_warnings = XCDR (Vpending_warnings); | |
| 853 | 3741 free_cons (this_warning_cons); |
| 1204 | 3742 class_ = XCAR (this_warning); |
| 428 | 3743 level = XCAR (XCDR (this_warning)); |
| 3744 messij = XCAR (XCDR (XCDR (this_warning))); | |
| 3745 free_list (this_warning); | |
| 3746 | |
| 3747 if (NILP (Vpending_warnings)) | |
| 3748 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary, | |
| 3749 but safer */ | |
| 3750 | |
| 1204 | 3751 GCPRO4 (form, class_, level, messij); |
| 428 | 3752 if (!STRINGP (messij)) |
| 3753 messij = Fprin1_to_string (messij, Qnil); | |
| 1204 | 3754 call3 (Qdisplay_warning, class_, messij, level); |
| 428 | 3755 UNGCPRO; |
| 771 | 3756 unbind_to (speccount); |
| 428 | 3757 } |
| 3758 | |
| 3759 QUIT; | |
| 814 | 3760 if (need_to_garbage_collect) |
| 428 | 3761 { |
| 3762 struct gcpro gcpro1; | |
| 3763 GCPRO1 (form); | |
| 3092 | 3764 #ifdef NEW_GC |
| 3765 gc_incremental (); | |
| 3766 #else /* not NEW_GC */ | |
| 428 | 3767 garbage_collect_1 (); |
| 3092 | 3768 #endif /* not NEW_GC */ |
| 428 | 3769 UNGCPRO; |
| 3770 } | |
| 3771 | |
| 3772 if (++lisp_eval_depth > max_lisp_eval_depth) | |
| 3773 { | |
| 3774 if (max_lisp_eval_depth < 100) | |
| 3775 max_lisp_eval_depth = 100; | |
| 3776 if (lisp_eval_depth > max_lisp_eval_depth) | |
| 563 | 3777 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'", |
| 3778 Qunbound); | |
| 428 | 3779 } |
| 3780 | |
| 3781 /* We guaranteed CONSP (form) above */ | |
| 3782 original_fun = XCAR (form); | |
| 3783 original_args = XCDR (form); | |
| 3784 | |
| 3785 GET_EXTERNAL_LIST_LENGTH (original_args, nargs); | |
| 3786 | |
| 3787 backtrace.pdlcount = specpdl_depth(); | |
| 3788 backtrace.function = &original_fun; /* This also protects them from gc */ | |
| 3789 backtrace.args = &original_args; | |
| 3790 backtrace.nargs = UNEVALLED; | |
| 3791 backtrace.evalargs = 1; | |
| 3792 backtrace.debug_on_exit = 0; | |
| 1292 | 3793 backtrace.function_being_called = 0; |
| 428 | 3794 PUSH_BACKTRACE (backtrace); |
| 3795 | |
| 3796 if (debug_on_next_call) | |
| 3797 do_debug_on_call (Qt); | |
| 3798 | |
| 3799 /* At this point, only original_fun and original_args | |
| 3800 have values that will be used below. */ | |
| 3801 retry: | |
| 3989 | 3802 /* Optimise for no indirection. */ |
| 3803 fun = original_fun; | |
| 3804 if (SYMBOLP (fun) && !EQ (fun, Qunbound) | |
| 3805 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) | |
| 3806 { | |
| 3807 fun = indirect_function(original_fun, 1); | |
| 3808 } | |
| 428 | 3809 |
| 3810 if (SUBRP (fun)) | |
| 3811 { | |
| 3812 Lisp_Subr *subr = XSUBR (fun); | |
| 3813 int max_args = subr->max_args; | |
| 3814 | |
| 3815 if (nargs < subr->min_args) | |
| 3816 goto wrong_number_of_arguments; | |
| 3817 | |
| 3818 if (max_args == UNEVALLED) /* Optimize for the common case */ | |
| 3819 { | |
| 3820 backtrace.evalargs = 0; | |
| 1292 | 3821 PROFILE_ENTER_FUNCTION (); |
| 428 | 3822 val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr)) |
| 3823 (original_args)); | |
| 1292 | 3824 PROFILE_EXIT_FUNCTION (); |
| 428 | 3825 } |
| 3826 else if (nargs <= max_args) | |
| 3827 { | |
| 3828 struct gcpro gcpro1; | |
| 3829 Lisp_Object args[SUBR_MAX_ARGS]; | |
| 3830 REGISTER Lisp_Object *p = args; | |
| 3831 | |
| 3832 GCPRO1 (args[0]); | |
| 3833 gcpro1.nvars = 0; | |
| 3834 | |
| 3835 { | |
| 3836 LIST_LOOP_2 (arg, original_args) | |
| 3837 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3838 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3839 gcpro1.nvars++; |
| 3840 } | |
| 3841 } | |
| 3842 | |
| 3843 /* &optional args default to nil. */ | |
| 3844 while (p - args < max_args) | |
| 3845 *p++ = Qnil; | |
| 3846 | |
| 3847 backtrace.args = args; | |
| 3848 backtrace.nargs = nargs; | |
| 3849 | |
| 1292 | 3850 PROFILE_ENTER_FUNCTION (); |
| 428 | 3851 FUNCALL_SUBR (val, subr, args, max_args); |
| 1292 | 3852 PROFILE_EXIT_FUNCTION (); |
| 428 | 3853 |
| 3854 UNGCPRO; | |
| 3855 } | |
| 3856 else if (max_args == MANY) | |
| 3857 { | |
| 3858 /* Pass a vector of evaluated arguments */ | |
| 3859 struct gcpro gcpro1; | |
| 3860 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3861 REGISTER Lisp_Object *p = args; | |
| 3862 | |
| 3863 GCPRO1 (args[0]); | |
| 3864 gcpro1.nvars = 0; | |
| 3865 | |
| 3866 { | |
| 3867 LIST_LOOP_2 (arg, original_args) | |
| 3868 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3869 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3870 gcpro1.nvars++; |
| 3871 } | |
| 3872 } | |
| 3873 | |
| 3874 backtrace.args = args; | |
| 3875 backtrace.nargs = nargs; | |
| 3876 | |
| 1292 | 3877 PROFILE_ENTER_FUNCTION (); |
| 428 | 3878 val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr)) |
| 3879 (nargs, args)); | |
| 1292 | 3880 PROFILE_EXIT_FUNCTION (); |
| 428 | 3881 |
| 3882 UNGCPRO; | |
| 3883 } | |
| 3884 else | |
| 3885 { | |
| 3886 wrong_number_of_arguments: | |
| 440 | 3887 val = signal_wrong_number_of_arguments_error (original_fun, nargs); |
| 428 | 3888 } |
| 3889 } | |
| 3890 else if (COMPILED_FUNCTIONP (fun)) | |
| 3891 { | |
| 3892 struct gcpro gcpro1; | |
| 3893 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3894 REGISTER Lisp_Object *p = args; | |
| 3895 | |
| 3896 GCPRO1 (args[0]); | |
| 3897 gcpro1.nvars = 0; | |
| 3898 | |
| 3899 { | |
| 3900 LIST_LOOP_2 (arg, original_args) | |
| 3901 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3902 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3903 gcpro1.nvars++; |
| 3904 } | |
| 3905 } | |
| 3906 | |
| 3907 backtrace.args = args; | |
| 3908 backtrace.nargs = nargs; | |
| 3909 backtrace.evalargs = 0; | |
| 3910 | |
| 1292 | 3911 PROFILE_ENTER_FUNCTION (); |
| 428 | 3912 val = funcall_compiled_function (fun, nargs, args); |
| 1292 | 3913 PROFILE_EXIT_FUNCTION (); |
| 428 | 3914 |
| 3915 /* Do the debug-on-exit now, while args is still GCPROed. */ | |
| 3916 if (backtrace.debug_on_exit) | |
| 3917 val = do_debug_on_exit (val); | |
| 3918 /* Don't do it again when we return to eval. */ | |
| 3919 backtrace.debug_on_exit = 0; | |
| 3920 | |
| 3921 UNGCPRO; | |
| 3922 } | |
| 3923 else if (CONSP (fun)) | |
| 3924 { | |
| 3925 Lisp_Object funcar = XCAR (fun); | |
| 3926 | |
| 3927 if (EQ (funcar, Qautoload)) | |
| 3928 { | |
| 970 | 3929 /* do_autoload GCPROs both arguments */ |
| 428 | 3930 do_autoload (fun, original_fun); |
| 3931 goto retry; | |
| 3932 } | |
| 3933 else if (EQ (funcar, Qmacro)) | |
| 3934 { | |
| 1292 | 3935 PROFILE_ENTER_FUNCTION (); |
| 428 | 3936 val = Feval (apply1 (XCDR (fun), original_args)); |
| 1292 | 3937 PROFILE_EXIT_FUNCTION (); |
| 428 | 3938 } |
| 3939 else if (EQ (funcar, Qlambda)) | |
| 3940 { | |
| 3941 struct gcpro gcpro1; | |
| 3942 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3943 REGISTER Lisp_Object *p = args; | |
| 3944 | |
| 3945 GCPRO1 (args[0]); | |
| 3946 gcpro1.nvars = 0; | |
| 3947 | |
| 3948 { | |
| 3949 LIST_LOOP_2 (arg, original_args) | |
| 3950 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3951 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3952 gcpro1.nvars++; |
| 3953 } | |
| 3954 } | |
| 3955 | |
| 3956 UNGCPRO; | |
| 3957 | |
| 3958 backtrace.args = args; /* this also GCPROs `args' */ | |
| 3959 backtrace.nargs = nargs; | |
| 3960 backtrace.evalargs = 0; | |
| 3961 | |
| 1292 | 3962 PROFILE_ENTER_FUNCTION (); |
| 428 | 3963 val = funcall_lambda (fun, nargs, args); |
| 1292 | 3964 PROFILE_EXIT_FUNCTION (); |
| 428 | 3965 |
| 3966 /* Do the debug-on-exit now, while args is still GCPROed. */ | |
| 3967 if (backtrace.debug_on_exit) | |
| 3968 val = do_debug_on_exit (val); | |
| 3969 /* Don't do it again when we return to eval. */ | |
| 3970 backtrace.debug_on_exit = 0; | |
| 3971 } | |
| 3972 else | |
| 3973 { | |
| 3974 goto invalid_function; | |
| 3975 } | |
| 3976 } | |
| 4104 | 3977 else if (UNBOUNDP (fun)) |
| 3978 { | |
| 3979 val = signal_void_function_error (original_fun); | |
| 3980 } | |
| 3981 else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun) | |
| 3982 UNBOUNDP (fun)) */ | |
| 428 | 3983 { |
| 3984 invalid_function: | |
| 436 | 3985 val = signal_invalid_function_error (fun); |
| 428 | 3986 } |
| 3987 | |
| 3988 lisp_eval_depth--; | |
| 3989 if (backtrace.debug_on_exit) | |
| 3990 val = do_debug_on_exit (val); | |
| 3991 POP_BACKTRACE (backtrace); | |
| 3992 return val; | |
| 3993 } | |
| 3994 | |
| 3995 | |
| 1111 | 3996 |
| 3997 static void | |
| 3998 run_post_gc_hook (void) | |
| 3999 { | |
| 4000 Lisp_Object args[2]; | |
| 4001 | |
| 4002 args[0] = Qpost_gc_hook; | |
| 4003 args[1] = Fcons (Fcons (Qfinalize_list, zap_finalize_list ()), Qnil); | |
| 4004 | |
| 4005 run_hook_with_args_trapping_problems | |
| 1333 | 4006 (Qgarbage_collecting, 2, args, RUN_HOOKS_TO_COMPLETION, |
| 1111 | 4007 INHIBIT_QUIT | NO_INHIBIT_ERRORS); |
| 4008 } | |
| 4009 | |
| 428 | 4010 DEFUN ("funcall", Ffuncall, 1, MANY, 0, /* |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4011 Call FUNCTION as a function, passing the remaining arguments to it. |
| 428 | 4012 Thus, (funcall 'cons 'x 'y) returns (x . y). |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4013 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4014 arguments: (FUNCTION &rest ARGS) |
| 428 | 4015 */ |
| 4016 (int nargs, Lisp_Object *args)) | |
| 4017 { | |
| 4018 /* This function can GC */ | |
| 4019 Lisp_Object fun; | |
| 4020 Lisp_Object val; | |
| 4162 | 4021 PROFILE_DECLARE(); |
| 428 | 4022 int fun_nargs = nargs - 1; |
| 4023 Lisp_Object *fun_args = args + 1; | |
| 4024 | |
| 1318 | 4025 /* QUIT will check for proper redisplay wrapping */ |
| 4026 | |
| 428 | 4027 QUIT; |
| 851 | 4028 |
| 4029 if (funcall_allocation_flag) | |
| 4030 { | |
| 4031 if (need_to_garbage_collect) | |
| 4032 /* Callers should gcpro lexpr args */ | |
| 3092 | 4033 #ifdef NEW_GC |
| 4034 gc_incremental (); | |
| 4035 #else /* not NEW_GC */ | |
| 851 | 4036 garbage_collect_1 (); |
| 3092 | 4037 #endif /* not NEW_GC */ |
| 851 | 4038 if (need_to_check_c_alloca) |
| 4039 { | |
| 4040 if (++funcall_alloca_count >= MAX_FUNCALLS_BETWEEN_ALLOCA_CLEANUP) | |
| 4041 { | |
| 4042 xemacs_c_alloca (0); | |
| 4043 funcall_alloca_count = 0; | |
| 4044 } | |
| 4045 } | |
| 887 | 4046 if (need_to_signal_post_gc) |
| 4047 { | |
| 4048 need_to_signal_post_gc = 0; | |
| 1111 | 4049 recompute_funcall_allocation_flag (); |
| 3263 | 4050 #ifdef NEW_GC |
| 4051 run_finalizers (); | |
| 4052 #endif /* NEW_GC */ | |
| 1111 | 4053 run_post_gc_hook (); |
| 887 | 4054 } |
| 851 | 4055 } |
| 428 | 4056 |
| 4057 if (++lisp_eval_depth > max_lisp_eval_depth) | |
| 4058 { | |
| 4059 if (max_lisp_eval_depth < 100) | |
| 4060 max_lisp_eval_depth = 100; | |
| 4061 if (lisp_eval_depth > max_lisp_eval_depth) | |
| 563 | 4062 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'", |
| 4063 Qunbound); | |
| 428 | 4064 } |
| 4065 | |
| 1292 | 4066 backtrace.pdlcount = specpdl_depth (); |
| 428 | 4067 backtrace.function = &args[0]; |
| 4068 backtrace.args = fun_args; | |
| 4069 backtrace.nargs = fun_nargs; | |
| 4070 backtrace.evalargs = 0; | |
| 4071 backtrace.debug_on_exit = 0; | |
| 1292 | 4072 backtrace.function_being_called = 0; |
| 428 | 4073 PUSH_BACKTRACE (backtrace); |
| 4074 | |
| 4075 if (debug_on_next_call) | |
| 4076 do_debug_on_call (Qlambda); | |
| 4077 | |
| 4078 retry: | |
| 4079 | |
| 4080 fun = args[0]; | |
| 4081 | |
| 4082 /* We could call indirect_function directly, but profiling shows | |
| 4083 this is worth optimizing by partially unrolling the loop. */ | |
| 4084 if (SYMBOLP (fun)) | |
| 4085 { | |
| 4086 fun = XSYMBOL (fun)->function; | |
| 4087 if (SYMBOLP (fun)) | |
| 4088 { | |
| 4089 fun = XSYMBOL (fun)->function; | |
| 4090 if (SYMBOLP (fun)) | |
| 4091 fun = indirect_function (fun, 1); | |
| 4092 } | |
| 4093 } | |
| 4094 | |
| 4095 if (SUBRP (fun)) | |
| 4096 { | |
| 4097 Lisp_Subr *subr = XSUBR (fun); | |
| 4098 int max_args = subr->max_args; | |
| 4099 Lisp_Object spacious_args[SUBR_MAX_ARGS]; | |
| 4100 | |
| 4101 if (fun_nargs == max_args) /* Optimize for the common case */ | |
| 4102 { | |
| 4103 funcall_subr: | |
| 1292 | 4104 PROFILE_ENTER_FUNCTION (); |
| 428 | 4105 FUNCALL_SUBR (val, subr, fun_args, max_args); |
| 1292 | 4106 PROFILE_EXIT_FUNCTION (); |
| 428 | 4107 } |
| 436 | 4108 else if (fun_nargs < subr->min_args) |
| 4109 { | |
| 4110 goto wrong_number_of_arguments; | |
| 4111 } | |
| 428 | 4112 else if (fun_nargs < max_args) |
| 4113 { | |
| 4114 Lisp_Object *p = spacious_args; | |
| 4115 | |
| 4116 /* Default optionals to nil */ | |
| 4117 while (fun_nargs--) | |
| 4118 *p++ = *fun_args++; | |
| 4119 while (p - spacious_args < max_args) | |
| 4120 *p++ = Qnil; | |
| 4121 | |
| 4122 fun_args = spacious_args; | |
| 4123 goto funcall_subr; | |
| 4124 } | |
| 4125 else if (max_args == MANY) | |
| 4126 { | |
| 1292 | 4127 PROFILE_ENTER_FUNCTION (); |
| 436 | 4128 val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args); |
| 1292 | 4129 PROFILE_EXIT_FUNCTION (); |
| 428 | 4130 } |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4131 else if (max_args == UNEVALLED) /* Can't funcall a special operator */ |
| 428 | 4132 { |
|
5222
18c0b5909d16
Use keywords in structure syntax; new #define, NEED_TO_HANDLE_21_4_CODE 1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5207
diff
changeset
|
4133 |
|
18c0b5909d16
Use keywords in structure syntax; new #define, NEED_TO_HANDLE_21_4_CODE 1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5207
diff
changeset
|
4134 #ifdef NEED_TO_HANDLE_21_4_CODE |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4135 /* Ugh, ugh, ugh. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4136 if (EQ (fun, XSYMBOL_FUNCTION (Qthrow))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4137 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4138 args[0] = Qobsolete_throw; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4139 goto retry; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4140 } |
|
5222
18c0b5909d16
Use keywords in structure syntax; new #define, NEED_TO_HANDLE_21_4_CODE 1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5207
diff
changeset
|
4141 #endif /* NEED_TO_HANDLE_21_4_CODE */ |
|
18c0b5909d16
Use keywords in structure syntax; new #define, NEED_TO_HANDLE_21_4_CODE 1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5207
diff
changeset
|
4142 |
| 428 | 4143 goto invalid_function; |
| 4144 } | |
| 4145 else | |
| 4146 { | |
| 4147 wrong_number_of_arguments: | |
| 436 | 4148 val = signal_wrong_number_of_arguments_error (fun, fun_nargs); |
| 428 | 4149 } |
| 4150 } | |
| 4151 else if (COMPILED_FUNCTIONP (fun)) | |
| 4152 { | |
| 1292 | 4153 PROFILE_ENTER_FUNCTION (); |
| 428 | 4154 val = funcall_compiled_function (fun, fun_nargs, fun_args); |
| 1292 | 4155 PROFILE_EXIT_FUNCTION (); |
| 428 | 4156 } |
| 4157 else if (CONSP (fun)) | |
| 4158 { | |
| 4159 Lisp_Object funcar = XCAR (fun); | |
| 4160 | |
| 4161 if (EQ (funcar, Qlambda)) | |
| 4162 { | |
| 1292 | 4163 PROFILE_ENTER_FUNCTION (); |
| 428 | 4164 val = funcall_lambda (fun, fun_nargs, fun_args); |
| 1292 | 4165 PROFILE_EXIT_FUNCTION (); |
| 428 | 4166 } |
| 4167 else if (EQ (funcar, Qautoload)) | |
| 4168 { | |
| 970 | 4169 /* do_autoload GCPROs both arguments */ |
| 428 | 4170 do_autoload (fun, args[0]); |
| 4171 goto retry; | |
| 4172 } | |
| 4173 else /* Can't funcall a macro */ | |
| 4174 { | |
| 4175 goto invalid_function; | |
| 4176 } | |
| 4177 } | |
| 4178 else if (UNBOUNDP (fun)) | |
| 4179 { | |
| 436 | 4180 val = signal_void_function_error (args[0]); |
| 428 | 4181 } |
| 4182 else | |
| 4183 { | |
| 4184 invalid_function: | |
| 436 | 4185 val = signal_invalid_function_error (fun); |
| 428 | 4186 } |
| 4187 | |
| 4188 lisp_eval_depth--; | |
| 4189 if (backtrace.debug_on_exit) | |
| 4190 val = do_debug_on_exit (val); | |
| 4191 POP_BACKTRACE (backtrace); | |
| 4192 return val; | |
| 4193 } | |
| 4194 | |
| 4195 DEFUN ("functionp", Ffunctionp, 1, 1, 0, /* | |
| 4196 Return t if OBJECT can be called as a function, else nil. | |
| 4197 A function is an object that can be applied to arguments, | |
| 4198 using for example `funcall' or `apply'. | |
| 4199 */ | |
| 4200 (object)) | |
| 4201 { | |
| 4202 if (SYMBOLP (object)) | |
| 4203 object = indirect_function (object, 0); | |
| 4204 | |
|
4795
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4744
diff
changeset
|
4205 if (COMPILED_FUNCTIONP (object) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4744
diff
changeset
|
4206 || (SUBRP (object) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4744
diff
changeset
|
4207 && (XSUBR (object)->max_args != UNEVALLED))) |
| 919 | 4208 return Qt; |
| 4209 if (CONSP (object)) | |
| 4210 { | |
| 4211 Lisp_Object car = XCAR (object); | |
| 4212 if (EQ (car, Qlambda)) | |
| 4213 return Qt; | |
| 4214 if (EQ (car, Qautoload) | |
|
4795
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4744
diff
changeset
|
4215 && NILP (Fcar_safe (Fcdr_safe(Fcdr_safe |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4744
diff
changeset
|
4216 (Fcdr_safe (XCDR (object))))))) |
| 919 | 4217 return Qt; |
| 4218 } | |
| 4219 return Qnil; | |
| 428 | 4220 } |
| 4221 | |
| 4222 static Lisp_Object | |
| 4223 function_argcount (Lisp_Object function, int function_min_args_p) | |
| 4224 { | |
| 4225 Lisp_Object orig_function = function; | |
| 4226 Lisp_Object arglist; | |
| 4227 | |
| 4228 retry: | |
| 4229 | |
| 4230 if (SYMBOLP (function)) | |
| 4231 function = indirect_function (function, 1); | |
| 4232 | |
| 4233 if (SUBRP (function)) | |
| 4234 { | |
| 442 | 4235 /* Using return with the ?: operator tickles a DEC CC compiler bug. */ |
| 4236 if (function_min_args_p) | |
| 4237 return Fsubr_min_args (function); | |
| 4238 else | |
| 4239 return Fsubr_max_args (function); | |
| 428 | 4240 } |
| 4241 else if (COMPILED_FUNCTIONP (function)) | |
| 4242 { | |
| 814 | 4243 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (function); |
| 4244 | |
| 1737 | 4245 if (!OPAQUEP (f->instructions)) |
| 4246 /* Lazily munge the instructions into a more efficient form */ | |
| 4247 /* Needed to set max_args */ | |
| 4248 optimize_compiled_function (function); | |
| 4249 | |
| 814 | 4250 if (function_min_args_p) |
| 4251 return make_int (f->min_args); | |
| 4252 else if (f->max_args == MANY) | |
| 4253 return Qnil; | |
| 4254 else | |
| 4255 return make_int (f->max_args); | |
| 428 | 4256 } |
| 4257 else if (CONSP (function)) | |
| 4258 { | |
| 4259 Lisp_Object funcar = XCAR (function); | |
| 4260 | |
| 4261 if (EQ (funcar, Qmacro)) | |
| 4262 { | |
| 4263 function = XCDR (function); | |
| 4264 goto retry; | |
| 4265 } | |
| 4266 else if (EQ (funcar, Qautoload)) | |
| 4267 { | |
| 970 | 4268 /* do_autoload GCPROs both arguments */ |
| 428 | 4269 do_autoload (function, orig_function); |
| 442 | 4270 function = orig_function; |
| 428 | 4271 goto retry; |
| 4272 } | |
| 4273 else if (EQ (funcar, Qlambda)) | |
| 4274 { | |
| 4275 arglist = Fcar (XCDR (function)); | |
| 4276 } | |
| 4277 else | |
| 4278 { | |
| 4279 goto invalid_function; | |
| 4280 } | |
| 4281 } | |
| 4282 else | |
| 4283 { | |
| 4284 invalid_function: | |
| 442 | 4285 return signal_invalid_function_error (orig_function); |
| 428 | 4286 } |
| 4287 | |
| 4288 { | |
| 4289 int argcount = 0; | |
| 4290 | |
| 4291 EXTERNAL_LIST_LOOP_2 (arg, arglist) | |
| 4292 { | |
| 4293 if (EQ (arg, Qand_optional)) | |
| 4294 { | |
| 4295 if (function_min_args_p) | |
| 4296 break; | |
| 4297 } | |
| 4298 else if (EQ (arg, Qand_rest)) | |
| 4299 { | |
| 4300 if (function_min_args_p) | |
| 4301 break; | |
| 4302 else | |
| 4303 return Qnil; | |
| 4304 } | |
| 4305 else | |
| 4306 { | |
| 4307 argcount++; | |
| 4308 } | |
| 4309 } | |
| 4310 | |
| 4311 return make_int (argcount); | |
| 4312 } | |
| 4313 } | |
| 4314 | |
| 4315 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /* | |
| 617 | 4316 Return the minimum number of arguments a function may be called with. |
| 428 | 4317 The function may be any form that can be passed to `funcall', |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4318 any special operator, or any macro. |
| 853 | 4319 |
| 4320 To check if a function can be called with a specified number of | |
| 4321 arguments, use `function-allows-args'. | |
| 428 | 4322 */ |
| 4323 (function)) | |
| 4324 { | |
| 4325 return function_argcount (function, 1); | |
| 4326 } | |
| 4327 | |
| 4328 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /* | |
| 617 | 4329 Return the maximum number of arguments a function may be called with. |
| 428 | 4330 The function may be any form that can be passed to `funcall', |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4331 any special operator, or any macro. |
| 428 | 4332 If the function takes an arbitrary number of arguments or is |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4333 a built-in special operator, nil is returned. |
| 853 | 4334 |
| 4335 To check if a function can be called with a specified number of | |
| 4336 arguments, use `function-allows-args'. | |
| 428 | 4337 */ |
| 4338 (function)) | |
| 4339 { | |
| 4340 return function_argcount (function, 0); | |
| 4341 } | |
| 4342 | |
| 4343 | |
| 4344 DEFUN ("apply", Fapply, 2, MANY, 0, /* | |
| 4345 Call FUNCTION with the remaining args, using the last arg as a list of args. | |
| 4346 Thus, (apply '+ 1 2 '(3 4)) returns 10. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4347 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4348 arguments: (FUNCTION &rest ARGS) |
| 428 | 4349 */ |
| 4350 (int nargs, Lisp_Object *args)) | |
| 4351 { | |
| 4352 /* This function can GC */ | |
| 4353 Lisp_Object fun = args[0]; | |
| 4354 Lisp_Object spread_arg = args [nargs - 1]; | |
| 4355 int numargs; | |
| 4356 int funcall_nargs; | |
| 4357 | |
| 4358 GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs); | |
| 4359 | |
| 4360 if (numargs == 0) | |
| 4361 /* (apply foo 0 1 '()) */ | |
| 4362 return Ffuncall (nargs - 1, args); | |
| 4363 else if (numargs == 1) | |
| 4364 { | |
| 4365 /* (apply foo 0 1 '(2)) */ | |
| 4366 args [nargs - 1] = XCAR (spread_arg); | |
| 4367 return Ffuncall (nargs, args); | |
| 4368 } | |
| 4369 | |
| 4370 /* -1 for function, -1 for spread arg */ | |
| 4371 numargs = nargs - 2 + numargs; | |
| 4372 /* +1 for function */ | |
| 4373 funcall_nargs = 1 + numargs; | |
| 4374 | |
| 4375 if (SYMBOLP (fun)) | |
| 4376 fun = indirect_function (fun, 0); | |
| 4377 | |
| 4378 if (SUBRP (fun)) | |
| 4379 { | |
| 4380 Lisp_Subr *subr = XSUBR (fun); | |
| 4381 int max_args = subr->max_args; | |
| 4382 | |
| 4383 if (numargs < subr->min_args | |
| 4384 || (max_args >= 0 && max_args < numargs)) | |
| 4385 { | |
| 4386 /* Let funcall get the error */ | |
| 4387 } | |
| 4388 else if (max_args > numargs) | |
| 4389 { | |
| 4390 /* Avoid having funcall cons up yet another new vector of arguments | |
| 4391 by explicitly supplying nil's for optional values */ | |
| 4392 funcall_nargs += (max_args - numargs); | |
| 4393 } | |
| 4394 } | |
| 4395 else if (UNBOUNDP (fun)) | |
| 4396 { | |
| 4397 /* Let funcall get the error */ | |
| 4398 fun = args[0]; | |
| 4399 } | |
| 4400 | |
| 4401 { | |
| 4402 REGISTER int i; | |
| 4403 Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs); | |
| 4404 struct gcpro gcpro1; | |
| 4405 | |
| 4406 GCPRO1 (*funcall_args); | |
| 4407 gcpro1.nvars = funcall_nargs; | |
| 4408 | |
| 4409 /* Copy in the unspread args */ | |
| 4410 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object)); | |
| 4411 /* Spread the last arg we got. Its first element goes in | |
| 4412 the slot that it used to occupy, hence this value of I. */ | |
| 4413 for (i = nargs - 1; | |
| 4414 !NILP (spread_arg); /* i < 1 + numargs */ | |
| 4415 i++, spread_arg = XCDR (spread_arg)) | |
| 4416 { | |
| 4417 funcall_args [i] = XCAR (spread_arg); | |
| 4418 } | |
| 4419 /* Supply nil for optional args (to subrs) */ | |
| 4420 for (; i < funcall_nargs; i++) | |
| 4421 funcall_args[i] = Qnil; | |
| 4422 | |
| 4423 | |
| 4424 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args)); | |
| 4425 } | |
| 4426 } | |
| 4427 | |
| 4428 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and | |
| 4429 return the result of evaluation. */ | |
| 4430 | |
| 4431 static Lisp_Object | |
| 4432 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[]) | |
| 4433 { | |
| 4434 /* This function can GC */ | |
| 442 | 4435 Lisp_Object arglist, body, tail; |
| 428 | 4436 int speccount = specpdl_depth(); |
| 4437 REGISTER int i = 0; | |
| 4438 | |
| 4439 tail = XCDR (fun); | |
| 4440 | |
| 4441 if (!CONSP (tail)) | |
| 4442 goto invalid_function; | |
| 4443 | |
| 4444 arglist = XCAR (tail); | |
| 4445 body = XCDR (tail); | |
| 4446 | |
| 4447 { | |
| 4448 int optional = 0, rest = 0; | |
| 4449 | |
| 442 | 4450 EXTERNAL_LIST_LOOP_2 (symbol, arglist) |
| 428 | 4451 { |
| 4452 if (!SYMBOLP (symbol)) | |
| 4453 goto invalid_function; | |
| 4454 if (EQ (symbol, Qand_rest)) | |
| 4455 rest = 1; | |
| 4456 else if (EQ (symbol, Qand_optional)) | |
| 4457 optional = 1; | |
| 4458 else if (rest) | |
| 4459 { | |
| 4460 specbind (symbol, Flist (nargs - i, &args[i])); | |
| 4461 i = nargs; | |
| 4462 } | |
| 4463 else if (i < nargs) | |
| 4464 specbind (symbol, args[i++]); | |
| 4465 else if (!optional) | |
| 4466 goto wrong_number_of_arguments; | |
| 4467 else | |
| 4468 specbind (symbol, Qnil); | |
| 4469 } | |
| 4470 } | |
| 4471 | |
| 4472 if (i < nargs) | |
| 4473 goto wrong_number_of_arguments; | |
| 4474 | |
| 771 | 4475 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 4476 |
| 4477 wrong_number_of_arguments: | |
| 436 | 4478 return signal_wrong_number_of_arguments_error (fun, nargs); |
| 428 | 4479 |
| 4480 invalid_function: | |
| 436 | 4481 return signal_invalid_function_error (fun); |
| 428 | 4482 } |
| 4483 | |
| 4484 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4485 /* Multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4486 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4487 A multiple value object is returned by #'values if: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4488 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4489 -- The number of arguments to #'values is not one, and: |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4490 -- Some special operator in the call stack is prepared to handle more than |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4491 one multiple value. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4492 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4493 The return value of #'values-list is analogous to that of #'values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4494 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4495 Henry Baker, in https://eprints.kfupm.edu.sa/31898/1/31898.pdf ("CONS |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4496 Should not CONS its Arguments, or, a Lazy Alloc is a Smart Alloc", ACM |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4497 Sigplan Notices 27,3 (March 1992),24-34.) says it should be possible to |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4498 allocate Common Lisp multiple-value objects on the stack, but this |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4499 assumes that variable-length records can be allocated on the stack, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4500 something not true for us. As far as I can tell, it also ignores the |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4501 contexts where multiple-values need to be thrown, or maybe it thinks such |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4502 objects should be converted to heap allocation at that point. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4503 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4504 The specific multiple values saved and returned depend on how many |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4505 multiple-values special operators in the stack are interested in; for |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4506 example, if #'multiple-value-call is somewhere in the call stack, all |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4507 values passed to #'values will be saved and returned. If an expansion of |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4508 #'multiple-value-setq with 10 SYMS is the only part of the call stack |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4509 interested in multiple values, then a maximum of ten multiple values will |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4510 be saved and returned. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4511 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4512 (#'throw passes back multiple values in its VALUE argument; this is why |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4513 we can't just take the details of the most immediate |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4514 #'multiple-value-{whatever} call to work out which values to save, we |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4515 need to look at the whole stack, or, equivalently, the dynamic variables |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4516 we set to reflect the whole stack.) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4517 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4518 The first value passed to #'values will always be saved, since that is |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4519 needed to convert a multiple value object into a single value object, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4520 something that is normally necessary independent of how many functions in |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4521 the call stack are interested in multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4522 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4523 However many values (for values of "however many" that are not one) are |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4524 saved and restored, the multiple value object knows how many arguments it |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4525 would contain were none to have been discarded, and will indicate this |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4526 on being printed from within GDB. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4527 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4528 In lisp-interaction-mode, no multiple values should be discarded (unless |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4529 they need to be for the sake of the correctness of the program); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4530 #'eval-interactive-with-multiple-value-list in lisp-mode.el wraps its |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4531 #'eval calls with #'multiple-value-list calls to avoid this. This means |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4532 that there is a small performance and memory penalty for code evaluated |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4533 in *scratch*; use M-: EXPRESSION RET if you really need to avoid |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4534 this. Lisp code execution that is not ultimately from hitting C-j in |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4535 *scratch*--that is, the vast vast majority of Lisp code execution--does |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4536 not have this penalty. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4537 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4538 Probably the most important aspect of multiple values is stated with |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4539 admirable clarity by CLTL2: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4540 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4541 "No matter how many values a form produces, if the form is an argument |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4542 form in a function call, then exactly one value (the first one) is |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4543 used." |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4544 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4545 This means that most contexts, most of the time, will never see multiple |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4546 values. There are important exceptions; search the web for that text in |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4547 quotation marks and read the related chapter. This code handles all of |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4548 them, to my knowledge. Aidan Kehoe, Mon Mar 16 00:17:39 GMT 2009. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4549 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4550 static Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4551 make_multiple_value (Lisp_Object first_value, Elemcount count, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4552 Elemcount first_desired, Elemcount upper_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4553 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4554 Bytecount sizem; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4555 struct multiple_value *mv; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4556 Elemcount i, allocated_count; |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4557 Lisp_Object mvobj; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4558 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4559 assert (count != 1); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4560 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4561 if (1 != upper_limit && (0 == first_desired)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4562 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4563 /* We always allocate element zero, and that's taken into account when |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4564 working out allocated_count: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4565 first_desired = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4566 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4567 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4568 if (first_desired >= count) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4569 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4570 /* We can't pass anything back that our caller is interested in. Only |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4571 allocate for the first argument. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4572 allocated_count = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4573 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4574 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4575 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4576 allocated_count = 1 + ((upper_limit > count ? count : upper_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4577 - first_desired); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4578 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4579 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4580 sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4581 Lisp_Object, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4582 contents, allocated_count); |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4583 mvobj = ALLOC_SIZED_LISP_OBJECT (sizem, multiple_value); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4584 mv = XMULTIPLE_VALUE (mvobj); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4585 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4586 mv->count = count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4587 mv->first_desired = first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4588 mv->allocated_count = allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4589 mv->contents[0] = first_value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4590 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4591 for (i = first_desired; i < upper_limit && i < count; ++i) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4592 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4593 mv->contents[1 + (i - first_desired)] = Qunbound; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4594 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4595 |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4596 return mvobj; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4597 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4598 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4599 void |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4600 multiple_value_aset (Lisp_Object obj, Elemcount index, Lisp_Object value) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4601 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4602 struct multiple_value *mv = XMULTIPLE_VALUE (obj); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4603 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4604 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4605 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4606 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4607 (index < first_desired || index >= (first_desired + allocated_count))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4608 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4609 args_out_of_range (make_int (first_desired), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4610 make_int (first_desired + allocated_count)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4611 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4612 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4613 mv->contents[index == 0 ? 0 : 1 + (index - first_desired)] = value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4614 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4615 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4616 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4617 multiple_value_aref (Lisp_Object obj, Elemcount index) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4618 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4619 struct multiple_value *mv = XMULTIPLE_VALUE (obj); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4620 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4621 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4622 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4623 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4624 (index < first_desired || index >= (first_desired + allocated_count))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4625 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4626 args_out_of_range (make_int (first_desired), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4627 make_int (first_desired + allocated_count)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4628 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4629 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4630 return mv->contents[index == 0 ? 0 : 1 + (index - first_desired)]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4631 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4632 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4633 static void |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4634 print_multiple_value (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4635 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4636 struct multiple_value *mv = XMULTIPLE_VALUE (obj); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4637 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4638 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4639 Elemcount count = mv->count, index; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4640 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4641 if (print_readably) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4642 { |
|
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:
5142
diff
changeset
|
4643 printing_unreadable_object_fmt ("#<multiple values 0x%x>", |
|
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:
5142
diff
changeset
|
4644 LISP_OBJECT_UID (obj)); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4645 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4646 |
|
5086
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4647 write_fmt_string (printcharfun, |
|
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4648 "#<INTERNAL OBJECT (XEmacs bug?) %d multiple values," |
|
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4649 " data (", count); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4650 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4651 for (index = 0; index < count;) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4652 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4653 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4654 (index < first_desired || |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4655 index >= (first_desired + (allocated_count - 1)))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4656 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4657 write_fmt_string (printcharfun, "#<discarded-multiple-value %d>", |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4658 index); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4659 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4660 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4661 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4662 print_internal (multiple_value_aref (obj, index), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4663 printcharfun, escapeflag); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4664 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4665 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4666 ++index; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4667 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4668 if (count > 1 && index < count) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4669 { |
|
5086
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4670 write_ascstring (printcharfun, " "); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4671 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4672 } |
|
5086
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4673 |
|
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:
5142
diff
changeset
|
4674 write_fmt_string (printcharfun, ") 0x%x>", LISP_OBJECT_UID (obj)); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4675 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4676 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4677 static Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4678 mark_multiple_value (Lisp_Object obj) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4679 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4680 struct multiple_value *mv = XMULTIPLE_VALUE (obj); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4681 Elemcount index, allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4682 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4683 for (index = 0; index < allocated_count; ++index) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4684 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4685 mark_object (mv->contents[index]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4686 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4687 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4688 return Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4689 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4690 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4691 static Bytecount |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4692 size_multiple_value (Lisp_Object obj) |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4693 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4694 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (struct multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4695 Lisp_Object, contents, |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4696 XMULTIPLE_VALUE (obj)->allocated_count); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4697 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4698 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4699 static const struct memory_description multiple_value_description[] = { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4700 { XD_LONG, offsetof (struct multiple_value, count) }, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4701 { XD_ELEMCOUNT, offsetof (struct multiple_value, allocated_count) }, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4702 { XD_LONG, offsetof (struct multiple_value, first_desired) }, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4703 { XD_LISP_OBJECT_ARRAY, offsetof (struct multiple_value, contents), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4704 XD_INDIRECT (1, 0) }, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4705 { XD_END } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4706 }; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4707 |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4708 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("multiple-value", multiple_value, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4709 mark_multiple_value, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4710 print_multiple_value, 0, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4711 0, /* No equal method. */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4712 0, /* No hash method. */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4713 multiple_value_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4714 size_multiple_value, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4715 struct multiple_value); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4716 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4717 /* Given that FIRST and UPPER are the inclusive lower and exclusive upper |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4718 bounds for the multiple values we're interested in, modify (or don't) the |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4719 special variables used to indicate this to #'values and #'values-list. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4720 Returns the specpdl_depth() value before any modification. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4721 int |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4722 bind_multiple_value_limits (int first, int upper) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4723 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4724 int result = specpdl_depth(); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4725 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4726 if (!(upper > first)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4727 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4728 invalid_argument ("MULTIPLE-VALUE-UPPER-LIMIT must be greater than " |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4729 " FIRST-DESIRED-MULTIPLE-VALUE", Qunbound); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4730 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4731 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4732 if (upper > Vmultiple_values_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4733 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4734 args_out_of_range (make_int (upper), make_int (Vmultiple_values_limit)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4735 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4736 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4737 /* In the event that something back up the stack wants more multiple |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4738 values than we do, we need to keep its figures for |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4739 first_desired_multiple_value or multiple_value_current_limit both. It |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4740 may be that the form will throw past us. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4741 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4742 If first_desired_multiple_value is zero, this means it hasn't ever been |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4743 bound, and any value we have for first is appropriate to use. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4744 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4745 Zeroth element is always saved, no need to note that: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4746 if (0 == first) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4747 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4748 first = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4749 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4750 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4751 if (0 == first_desired_multiple_value |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4752 || first < first_desired_multiple_value) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4753 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4754 internal_bind_int (&first_desired_multiple_value, first); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4755 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4756 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4757 if (upper > multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4758 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4759 internal_bind_int (&multiple_value_current_limit, upper); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4760 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4761 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4762 return result; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4763 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4764 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4765 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4766 multiple_value_call (int nargs, Lisp_Object *args) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4767 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4768 /* The argument order here is horrible: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4769 int i, speccount = XINT (args[3]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4770 Lisp_Object result = Qnil, head = Fcons (args[0], Qnil), list_offset; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4771 struct gcpro gcpro1, gcpro2; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4772 Lisp_Object apply_args[2]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4773 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4774 GCPRO2 (head, result); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4775 list_offset = head; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4776 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4777 assert (!(MULTIPLE_VALUEP (args[0]))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4778 CHECK_FUNCTION (args[0]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4779 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4780 /* Start at 4, to ignore the function, the speccount, and the arguments to |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4781 multiple-values-limit (which we don't discard because |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4782 #'multiple-value-list-internal needs them): */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4783 for (i = 4; i < nargs; ++i) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4784 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4785 result = args[i]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4786 if (MULTIPLE_VALUEP (result)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4787 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4788 Lisp_Object val; |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4789 Elemcount j, count = XMULTIPLE_VALUE_COUNT (result); |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4790 |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4791 for (j = 0; j < count; j++) |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4792 { |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4793 val = multiple_value_aref (result, j); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4794 assert (!UNBOUNDP (val)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4795 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4796 XSETCDR (list_offset, Fcons (val, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4797 list_offset = XCDR (list_offset); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4798 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4799 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4800 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4801 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4802 XSETCDR (list_offset, Fcons (result, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4803 list_offset = XCDR (list_offset); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4804 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4805 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4806 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4807 apply_args [0] = XCAR (head); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4808 apply_args [1] = XCDR (head); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4809 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4810 unbind_to (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4811 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4812 RETURN_UNGCPRO (Fapply (countof(apply_args), apply_args)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4813 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4814 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4815 DEFUN ("multiple-value-call", Fmultiple_value_call, 1, UNEVALLED, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4816 Call FUNCTION with arguments FORMS, using multiple values when returned. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4817 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4818 All of the (possibly multiple) values returned by each form in FORMS are |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4819 gathered together, and given as arguments to FUNCTION; conceptually, this |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4820 function is a version of `apply' that by-passes the multiple values |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4821 infrastructure, treating multiple values as intercalated lists. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4822 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4823 arguments: (FUNCTION &rest FORMS) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4824 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4825 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4826 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4827 int listcount, i = 0, speccount; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4828 Lisp_Object *constructed_args; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4829 struct gcpro gcpro1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4830 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4831 GET_EXTERNAL_LIST_LENGTH (args, listcount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4832 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4833 constructed_args = alloca_array (Lisp_Object, listcount + 3); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4834 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4835 /* Fcar so we error on non-cons: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4836 constructed_args[i] = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4837 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4838 GCPRO1 (*constructed_args); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4839 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4840 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4841 /* The argument order is horrible here. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4842 constructed_args[i] = make_int (0); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4843 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4844 constructed_args[i] = make_int (Vmultiple_values_limit); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4845 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4846 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4847 speccount = bind_multiple_value_limits (0, Vmultiple_values_limit); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4848 constructed_args[i] = make_int (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4849 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4850 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4851 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4852 LIST_LOOP_2 (elt, XCDR (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4853 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4854 constructed_args[i] = Feval (elt); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4855 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4856 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4857 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4858 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4859 RETURN_UNGCPRO (multiple_value_call (listcount + 3, constructed_args)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4860 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4861 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4862 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4863 multiple_value_list_internal (int nargs, Lisp_Object *args) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4864 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4865 int first = XINT (args[0]), upper = XINT (args[1]), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4866 speccount = XINT(args[2]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4867 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4868 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4869 assert (nargs == 4); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4870 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4871 result = args[3]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4872 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4873 unbind_to (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4874 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4875 if (MULTIPLE_VALUEP (result)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4876 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4877 Lisp_Object head = Fcons (Qnil, Qnil); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4878 Lisp_Object list_offset = head, val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4879 Elemcount count = XMULTIPLE_VALUE_COUNT(result); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4880 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4881 for (; first < upper && first < count; ++first) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4882 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4883 val = multiple_value_aref (result, first); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4884 assert (!UNBOUNDP (val)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4885 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4886 XSETCDR (list_offset, Fcons (val, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4887 list_offset = XCDR (list_offset); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4888 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4889 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4890 return XCDR (head); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4891 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4892 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4893 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4894 if (first == 0) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4895 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4896 return Fcons (result, Qnil); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4897 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4898 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4899 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4900 return Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4901 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4902 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4903 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4904 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4905 DEFUN ("multiple-value-list-internal", Fmultiple_value_list_internal, 3, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4906 UNEVALLED, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4907 Evaluate FORM. Return a list of multiple vals reflecting the other two args. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4908 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4909 Don't use this. Use `multiple-value-list', the macro specified by Common |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4910 Lisp, instead. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4911 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4912 FIRST-DESIRED-MULTIPLE-VALUE is the first element in list of multiple values |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4913 to pass back. MULTIPLE-VALUE-UPPER-LIMIT is the exclusive upper limit on |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4914 the indexes within the values that may be passed back; this function will |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4915 never return a list longer than MULTIPLE-VALUE-UPPER-LIMIT - |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4916 FIRST-DESIRED-MULTIPLE-VALUE. It may return a list shorter than that, if |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4917 `values' or `values-list' do not supply enough elements. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4918 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4919 arguments: (FIRST-DESIRED-MULTIPLE-VALUE MULTIPLE-VALUE-UPPER-LIMIT FORM) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4920 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4921 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4922 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4923 Lisp_Object argv[4]; |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4924 int first, upper, nargs; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4925 struct gcpro gcpro1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4926 |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4927 GET_LIST_LENGTH (args, nargs); |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4928 if (nargs != 3) |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4929 { |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4930 Fsignal (Qwrong_number_of_arguments, |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4931 list2 (Qmultiple_value_list_internal, make_int (nargs))); |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4932 } |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4933 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4934 argv[0] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4935 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4936 GCPRO1 (argv[0]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4937 gcpro1.nvars = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4938 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4939 args = XCDR (args); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4940 argv[1] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
4941 |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
4942 check_integer_range (argv[1], Qzero, make_int (EMACS_INT_MAX)); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
4943 check_integer_range (argv[0], Qzero, argv[1]); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
4944 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4945 upper = XINT (argv[1]); |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
4946 first = XINT (argv[0]); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
4947 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4948 gcpro1.nvars = 2; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4949 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4950 /* The unintuitive order of things here is for the sake of the bytecode; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4951 the alternative would be to encode the number of arguments in the |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4952 bytecode stream, which complicates things if we have more than 255 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4953 arguments. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4954 argv[2] = make_int (bind_multiple_value_limits (first, upper)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4955 gcpro1.nvars = 3; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4956 args = XCDR (args); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4957 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4958 /* GCPROing in this function is not strictly necessary, this Feval is the |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4959 only point that may cons up data that is not immediately discarded, and |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4960 within it is the only point (in Fmultiple_value_list_internal and |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4961 multiple_value_list) that we can garbage collect. But I'm conservative, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4962 and this function is called so rarely (only from interpreted code) that |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4963 it doesn't matter for performance. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4964 argv[3] = Feval (XCAR (args)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4965 gcpro1.nvars = 4; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4966 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4967 RETURN_UNGCPRO (multiple_value_list_internal (countof (argv), argv)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4968 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4969 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4970 DEFUN ("multiple-value-prog1", Fmultiple_value_prog1, 1, UNEVALLED, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4971 Similar to `prog1', but return any multiple values from the first form. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4972 `prog1' itself will never return multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4973 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4974 arguments: (FIRST &rest BODY) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4975 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4976 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4977 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4978 /* This function can GC */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4979 Lisp_Object val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4980 struct gcpro gcpro1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4981 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4982 val = Feval (XCAR (args)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4983 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4984 GCPRO1 (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4985 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4986 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4987 LIST_LOOP_2 (form, XCDR (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4988 Feval (form); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4989 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4990 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4991 RETURN_UNGCPRO (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4992 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4993 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4994 DEFUN ("values", Fvalues, 0, MANY, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4995 Return all ARGS as multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4996 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4997 arguments: (&rest ARGS) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4998 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4999 (int nargs, Lisp_Object *args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5000 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5001 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5002 int counting = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5003 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5004 /* Pathological cases, no need to cons up an object: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5005 if (1 == nargs || 1 == multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5006 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5007 return nargs ? args[0] : Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5008 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5009 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5010 /* If nargs is zero, this code is correct and desirable. With |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5011 #'multiple-value-call, we want zero-length multiple values in the |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5012 argument list to be discarded entirely, and we can't do this if we |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5013 transform them to nil. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5014 result = make_multiple_value (nargs ? args[0] : Qnil, nargs, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5015 first_desired_multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5016 multiple_value_current_limit); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5017 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5018 for (; counting < nargs; ++counting) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5019 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5020 if (counting >= first_desired_multiple_value && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5021 counting < multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5022 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5023 multiple_value_aset (result, counting, args[counting]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5024 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5025 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5026 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5027 return result; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5028 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5029 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5030 DEFUN ("values-list", Fvalues_list, 1, 1, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5031 Return all the elements of LIST as multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5032 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5033 (list)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5034 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5035 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5036 int counting = 1, listcount; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5037 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5038 GET_EXTERNAL_LIST_LENGTH (list, listcount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5039 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5040 /* Pathological cases, no need to cons up an object: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5041 if (1 == listcount || 1 == multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5042 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5043 return Fcar_safe (list); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5044 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5045 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5046 result = make_multiple_value (Fcar_safe (list), listcount, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5047 first_desired_multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5048 multiple_value_current_limit); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5049 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5050 list = Fcdr_safe (list); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5051 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5052 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5053 EXTERNAL_LIST_LOOP_2 (elt, list) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5054 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5055 if (counting >= first_desired_multiple_value && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5056 counting < multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5057 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5058 multiple_value_aset (result, counting, elt); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5059 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5060 ++counting; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5061 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5062 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5063 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5064 return result; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5065 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5066 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5067 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5068 values2 (Lisp_Object first, Lisp_Object second) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5069 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5070 Lisp_Object argv[2]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5071 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5072 argv[0] = first; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5073 argv[1] = second; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5074 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5075 return Fvalues (countof (argv), argv); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5076 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5077 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5078 |
| 428 | 5079 /************************************************************************/ |
| 5080 /* Run hook variables in various ways. */ | |
| 5081 /************************************************************************/ | |
| 5082 | |
| 5083 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /* | |
| 5084 Run each hook in HOOKS. Major mode functions use this. | |
| 5085 Each argument should be a symbol, a hook variable. | |
| 5086 These symbols are processed in the order specified. | |
| 5087 If a hook symbol has a non-nil value, that value may be a function | |
| 5088 or a list of functions to be called to run the hook. | |
| 5089 If the value is a function, it is called with no arguments. | |
| 5090 If it is a list, the elements are called, in order, with no arguments. | |
| 5091 | |
| 5092 To make a hook variable buffer-local, use `make-local-hook', | |
| 5093 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5094 |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
5095 arguments: (FIRST &rest REST) |
| 428 | 5096 */ |
| 5097 (int nargs, Lisp_Object *args)) | |
| 5098 { | |
| 5099 REGISTER int i; | |
| 5100 | |
| 5101 for (i = 0; i < nargs; i++) | |
| 5102 run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION); | |
| 5103 | |
| 5104 return Qnil; | |
| 5105 } | |
| 5106 | |
| 5107 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /* | |
| 5108 Run HOOK with the specified arguments ARGS. | |
| 5109 HOOK should be a symbol, a hook variable. If HOOK has a non-nil | |
| 5110 value, that value may be a function or a list of functions to be | |
| 5111 called to run the hook. If the value is a function, it is called with | |
| 5112 the given arguments and its return value is returned. If it is a list | |
| 5113 of functions, those functions are called, in order, | |
| 5114 with the given arguments ARGS. | |
| 444 | 5115 It is best not to depend on the value returned by `run-hook-with-args', |
| 428 | 5116 as that may change. |
| 5117 | |
| 5118 To make a hook variable buffer-local, use `make-local-hook', | |
| 5119 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5120 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5121 arguments: (HOOK &rest ARGS) |
| 428 | 5122 */ |
| 5123 (int nargs, Lisp_Object *args)) | |
| 5124 { | |
| 5125 return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION); | |
| 5126 } | |
| 5127 | |
| 5128 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /* | |
| 5129 Run HOOK with the specified arguments ARGS. | |
| 5130 HOOK should be a symbol, a hook variable. Its value should | |
| 5131 be a list of functions. We call those functions, one by one, | |
| 5132 passing arguments ARGS to each of them, until one of them | |
| 5133 returns a non-nil value. Then we return that value. | |
| 5134 If all the functions return nil, we return nil. | |
| 5135 | |
| 5136 To make a hook variable buffer-local, use `make-local-hook', | |
| 5137 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5138 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5139 arguments: (HOOK &rest ARGS) |
| 428 | 5140 */ |
| 5141 (int nargs, Lisp_Object *args)) | |
| 5142 { | |
| 5143 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS); | |
| 5144 } | |
| 5145 | |
| 5146 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /* | |
| 5147 Run HOOK with the specified arguments ARGS. | |
| 5148 HOOK should be a symbol, a hook variable. Its value should | |
| 5149 be a list of functions. We call those functions, one by one, | |
| 5150 passing arguments ARGS to each of them, until one of them | |
| 5151 returns nil. Then we return nil. | |
| 5152 If all the functions return non-nil, we return non-nil. | |
| 5153 | |
| 5154 To make a hook variable buffer-local, use `make-local-hook', | |
| 5155 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5156 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5157 arguments: (HOOK &rest ARGS) |
| 428 | 5158 */ |
| 5159 (int nargs, Lisp_Object *args)) | |
| 5160 { | |
| 5161 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE); | |
| 5162 } | |
| 5163 | |
| 5164 /* ARGS[0] should be a hook symbol. | |
| 5165 Call each of the functions in the hook value, passing each of them | |
| 5166 as arguments all the rest of ARGS (all NARGS - 1 elements). | |
| 5167 COND specifies a condition to test after each call | |
| 5168 to decide whether to stop. | |
| 5169 The caller (or its caller, etc) must gcpro all of ARGS, | |
| 5170 except that it isn't necessary to gcpro ARGS[0]. */ | |
| 5171 | |
| 5172 Lisp_Object | |
| 5173 run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args, | |
| 5174 enum run_hooks_condition cond) | |
| 5175 { | |
| 5176 Lisp_Object sym, val, ret; | |
| 5177 | |
| 5178 if (!initialized || preparing_for_armageddon) | |
| 5179 /* We need to bail out of here pronto. */ | |
| 5180 return Qnil; | |
| 5181 | |
| 3092 | 5182 #ifndef NEW_GC |
| 428 | 5183 /* Whenever gc_in_progress is true, preparing_for_armageddon |
| 5184 will also be true unless something is really hosed. */ | |
| 5185 assert (!gc_in_progress); | |
| 3092 | 5186 #endif /* not NEW_GC */ |
| 428 | 5187 |
| 5188 sym = args[0]; | |
| 771 | 5189 val = symbol_value_in_buffer (sym, wrap_buffer (buf)); |
| 428 | 5190 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil); |
| 5191 | |
| 5192 if (UNBOUNDP (val) || NILP (val)) | |
| 5193 return ret; | |
| 5194 else if (!CONSP (val) || EQ (XCAR (val), Qlambda)) | |
| 5195 { | |
| 5196 args[0] = val; | |
| 5197 return Ffuncall (nargs, args); | |
| 5198 } | |
| 5199 else | |
| 5200 { | |
| 5201 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 5202 Lisp_Object globals = Qnil; | |
| 5203 GCPRO3 (sym, val, globals); | |
| 5204 | |
| 5205 for (; | |
| 5206 CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION) | |
| 5207 || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret) | |
| 5208 : !NILP (ret))); | |
| 5209 val = XCDR (val)) | |
| 5210 { | |
| 5211 if (EQ (XCAR (val), Qt)) | |
| 5212 { | |
| 5213 /* t indicates this hook has a local binding; | |
| 5214 it means to run the global binding too. */ | |
| 5215 globals = Fdefault_value (sym); | |
| 5216 | |
| 5217 if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) && | |
| 5218 ! NILP (globals)) | |
| 5219 { | |
| 5220 args[0] = globals; | |
| 5221 ret = Ffuncall (nargs, args); | |
| 5222 } | |
| 5223 else | |
| 5224 { | |
| 5225 for (; | |
| 5226 CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION) | |
| 5227 || (cond == RUN_HOOKS_UNTIL_SUCCESS | |
| 5228 ? NILP (ret) | |
| 5229 : !NILP (ret))); | |
| 5230 globals = XCDR (globals)) | |
| 5231 { | |
| 5232 args[0] = XCAR (globals); | |
| 5233 /* In a global value, t should not occur. If it does, we | |
| 5234 must ignore it to avoid an endless loop. */ | |
| 5235 if (!EQ (args[0], Qt)) | |
| 5236 ret = Ffuncall (nargs, args); | |
| 5237 } | |
| 5238 } | |
| 5239 } | |
| 5240 else | |
| 5241 { | |
| 5242 args[0] = XCAR (val); | |
| 5243 ret = Ffuncall (nargs, args); | |
| 5244 } | |
| 5245 } | |
| 5246 | |
| 5247 UNGCPRO; | |
| 5248 return ret; | |
| 5249 } | |
| 5250 } | |
| 5251 | |
| 5252 Lisp_Object | |
| 5253 run_hook_with_args (int nargs, Lisp_Object *args, | |
| 5254 enum run_hooks_condition cond) | |
| 5255 { | |
| 5256 return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond); | |
| 5257 } | |
| 5258 | |
| 5259 #if 0 | |
| 5260 | |
| 853 | 5261 /* From FSF 19.30, not currently used; seems like a big kludge. */ |
| 428 | 5262 |
| 5263 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual | |
| 5264 present value of that symbol. | |
| 5265 Call each element of FUNLIST, | |
| 5266 passing each of them the rest of ARGS. | |
| 5267 The caller (or its caller, etc) must gcpro all of ARGS, | |
| 5268 except that it isn't necessary to gcpro ARGS[0]. */ | |
| 5269 | |
| 5270 Lisp_Object | |
| 5271 run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args) | |
| 5272 { | |
| 853 | 5273 omitted; |
| 428 | 5274 } |
| 5275 | |
| 5276 #endif /* 0 */ | |
| 5277 | |
| 5278 void | |
| 5279 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...) | |
| 5280 { | |
| 5281 /* This function can GC */ | |
| 5282 struct gcpro gcpro1; | |
| 5283 int i; | |
| 5284 va_list vargs; | |
| 5285 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 5286 | |
| 5287 va_start (vargs, nargs); | |
| 5288 funcall_args[0] = hook_var; | |
| 5289 for (i = 0; i < nargs; i++) | |
| 5290 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 5291 va_end (vargs); | |
| 5292 | |
| 5293 GCPRO1 (*funcall_args); | |
| 5294 gcpro1.nvars = nargs + 1; | |
| 5295 run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION); | |
| 5296 UNGCPRO; | |
| 5297 } | |
| 5298 | |
| 5299 void | |
| 5300 va_run_hook_with_args_in_buffer (struct buffer *buf, Lisp_Object hook_var, | |
| 5301 int nargs, ...) | |
| 5302 { | |
| 5303 /* This function can GC */ | |
| 5304 struct gcpro gcpro1; | |
| 5305 int i; | |
| 5306 va_list vargs; | |
| 5307 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 5308 | |
| 5309 va_start (vargs, nargs); | |
| 5310 funcall_args[0] = hook_var; | |
| 5311 for (i = 0; i < nargs; i++) | |
| 5312 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 5313 va_end (vargs); | |
| 5314 | |
| 5315 GCPRO1 (*funcall_args); | |
| 5316 gcpro1.nvars = nargs + 1; | |
| 5317 run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args, | |
| 5318 RUN_HOOKS_TO_COMPLETION); | |
| 5319 UNGCPRO; | |
| 5320 } | |
| 5321 | |
| 5322 Lisp_Object | |
| 5323 run_hook (Lisp_Object hook) | |
| 5324 { | |
| 853 | 5325 return run_hook_with_args (1, &hook, RUN_HOOKS_TO_COMPLETION); |
| 428 | 5326 } |
| 5327 | |
| 5328 | |
| 5329 /************************************************************************/ | |
| 5330 /* Front-ends to eval, funcall, apply */ | |
| 5331 /************************************************************************/ | |
| 5332 | |
| 5333 /* Apply fn to arg */ | |
| 5334 Lisp_Object | |
| 5335 apply1 (Lisp_Object fn, Lisp_Object arg) | |
| 5336 { | |
| 5337 /* This function can GC */ | |
| 5338 struct gcpro gcpro1; | |
| 5339 Lisp_Object args[2]; | |
| 5340 | |
| 5341 if (NILP (arg)) | |
| 5342 return Ffuncall (1, &fn); | |
| 5343 GCPRO1 (args[0]); | |
| 5344 gcpro1.nvars = 2; | |
| 5345 args[0] = fn; | |
| 5346 args[1] = arg; | |
| 5347 RETURN_UNGCPRO (Fapply (2, args)); | |
| 5348 } | |
| 5349 | |
| 5350 /* Call function fn on no arguments */ | |
| 5351 Lisp_Object | |
| 5352 call0 (Lisp_Object fn) | |
| 5353 { | |
| 5354 /* This function can GC */ | |
| 5355 struct gcpro gcpro1; | |
| 5356 | |
| 5357 GCPRO1 (fn); | |
| 5358 RETURN_UNGCPRO (Ffuncall (1, &fn)); | |
| 5359 } | |
| 5360 | |
| 5361 /* Call function fn with argument arg0 */ | |
| 5362 Lisp_Object | |
| 5363 call1 (Lisp_Object fn, | |
| 5364 Lisp_Object arg0) | |
| 5365 { | |
| 5366 /* This function can GC */ | |
| 5367 struct gcpro gcpro1; | |
| 5368 Lisp_Object args[2]; | |
| 5369 args[0] = fn; | |
| 5370 args[1] = arg0; | |
| 5371 GCPRO1 (args[0]); | |
| 5372 gcpro1.nvars = 2; | |
| 5373 RETURN_UNGCPRO (Ffuncall (2, args)); | |
| 5374 } | |
| 5375 | |
| 5376 /* Call function fn with arguments arg0, arg1 */ | |
| 5377 Lisp_Object | |
| 5378 call2 (Lisp_Object fn, | |
| 5379 Lisp_Object arg0, Lisp_Object arg1) | |
| 5380 { | |
| 5381 /* This function can GC */ | |
| 5382 struct gcpro gcpro1; | |
| 5383 Lisp_Object args[3]; | |
| 5384 args[0] = fn; | |
| 5385 args[1] = arg0; | |
| 5386 args[2] = arg1; | |
| 5387 GCPRO1 (args[0]); | |
| 5388 gcpro1.nvars = 3; | |
| 5389 RETURN_UNGCPRO (Ffuncall (3, args)); | |
| 5390 } | |
| 5391 | |
| 5392 /* Call function fn with arguments arg0, arg1, arg2 */ | |
| 5393 Lisp_Object | |
| 5394 call3 (Lisp_Object fn, | |
| 5395 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2) | |
| 5396 { | |
| 5397 /* This function can GC */ | |
| 5398 struct gcpro gcpro1; | |
| 5399 Lisp_Object args[4]; | |
| 5400 args[0] = fn; | |
| 5401 args[1] = arg0; | |
| 5402 args[2] = arg1; | |
| 5403 args[3] = arg2; | |
| 5404 GCPRO1 (args[0]); | |
| 5405 gcpro1.nvars = 4; | |
| 5406 RETURN_UNGCPRO (Ffuncall (4, args)); | |
| 5407 } | |
| 5408 | |
| 5409 /* Call function fn with arguments arg0, arg1, arg2, arg3 */ | |
| 5410 Lisp_Object | |
| 5411 call4 (Lisp_Object fn, | |
| 5412 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5413 Lisp_Object arg3) | |
| 5414 { | |
| 5415 /* This function can GC */ | |
| 5416 struct gcpro gcpro1; | |
| 5417 Lisp_Object args[5]; | |
| 5418 args[0] = fn; | |
| 5419 args[1] = arg0; | |
| 5420 args[2] = arg1; | |
| 5421 args[3] = arg2; | |
| 5422 args[4] = arg3; | |
| 5423 GCPRO1 (args[0]); | |
| 5424 gcpro1.nvars = 5; | |
| 5425 RETURN_UNGCPRO (Ffuncall (5, args)); | |
| 5426 } | |
| 5427 | |
| 5428 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */ | |
| 5429 Lisp_Object | |
| 5430 call5 (Lisp_Object fn, | |
| 5431 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5432 Lisp_Object arg3, Lisp_Object arg4) | |
| 5433 { | |
| 5434 /* This function can GC */ | |
| 5435 struct gcpro gcpro1; | |
| 5436 Lisp_Object args[6]; | |
| 5437 args[0] = fn; | |
| 5438 args[1] = arg0; | |
| 5439 args[2] = arg1; | |
| 5440 args[3] = arg2; | |
| 5441 args[4] = arg3; | |
| 5442 args[5] = arg4; | |
| 5443 GCPRO1 (args[0]); | |
| 5444 gcpro1.nvars = 6; | |
| 5445 RETURN_UNGCPRO (Ffuncall (6, args)); | |
| 5446 } | |
| 5447 | |
| 5448 Lisp_Object | |
| 5449 call6 (Lisp_Object fn, | |
| 5450 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5451 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5) | |
| 5452 { | |
| 5453 /* This function can GC */ | |
| 5454 struct gcpro gcpro1; | |
| 5455 Lisp_Object args[7]; | |
| 5456 args[0] = fn; | |
| 5457 args[1] = arg0; | |
| 5458 args[2] = arg1; | |
| 5459 args[3] = arg2; | |
| 5460 args[4] = arg3; | |
| 5461 args[5] = arg4; | |
| 5462 args[6] = arg5; | |
| 5463 GCPRO1 (args[0]); | |
| 5464 gcpro1.nvars = 7; | |
| 5465 RETURN_UNGCPRO (Ffuncall (7, args)); | |
| 5466 } | |
| 5467 | |
| 5468 Lisp_Object | |
| 5469 call7 (Lisp_Object fn, | |
| 5470 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5471 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, | |
| 5472 Lisp_Object arg6) | |
| 5473 { | |
| 5474 /* This function can GC */ | |
| 5475 struct gcpro gcpro1; | |
| 5476 Lisp_Object args[8]; | |
| 5477 args[0] = fn; | |
| 5478 args[1] = arg0; | |
| 5479 args[2] = arg1; | |
| 5480 args[3] = arg2; | |
| 5481 args[4] = arg3; | |
| 5482 args[5] = arg4; | |
| 5483 args[6] = arg5; | |
| 5484 args[7] = arg6; | |
| 5485 GCPRO1 (args[0]); | |
| 5486 gcpro1.nvars = 8; | |
| 5487 RETURN_UNGCPRO (Ffuncall (8, args)); | |
| 5488 } | |
| 5489 | |
| 5490 Lisp_Object | |
| 5491 call8 (Lisp_Object fn, | |
| 5492 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5493 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, | |
| 5494 Lisp_Object arg6, Lisp_Object arg7) | |
| 5495 { | |
| 5496 /* This function can GC */ | |
| 5497 struct gcpro gcpro1; | |
| 5498 Lisp_Object args[9]; | |
| 5499 args[0] = fn; | |
| 5500 args[1] = arg0; | |
| 5501 args[2] = arg1; | |
| 5502 args[3] = arg2; | |
| 5503 args[4] = arg3; | |
| 5504 args[5] = arg4; | |
| 5505 args[6] = arg5; | |
| 5506 args[7] = arg6; | |
| 5507 args[8] = arg7; | |
| 5508 GCPRO1 (args[0]); | |
| 5509 gcpro1.nvars = 9; | |
| 5510 RETURN_UNGCPRO (Ffuncall (9, args)); | |
| 5511 } | |
| 5512 | |
| 5513 Lisp_Object | |
| 5514 call0_in_buffer (struct buffer *buf, Lisp_Object fn) | |
| 5515 { | |
| 5516 if (current_buffer == buf) | |
| 5517 return call0 (fn); | |
| 5518 else | |
| 5519 { | |
| 5520 Lisp_Object val; | |
| 5521 int speccount = specpdl_depth(); | |
| 5522 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5523 set_buffer_internal (buf); | |
| 5524 val = call0 (fn); | |
| 771 | 5525 unbind_to (speccount); |
| 428 | 5526 return val; |
| 5527 } | |
| 5528 } | |
| 5529 | |
| 5530 Lisp_Object | |
| 5531 call1_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5532 Lisp_Object arg0) | |
| 5533 { | |
| 5534 if (current_buffer == buf) | |
| 5535 return call1 (fn, arg0); | |
| 5536 else | |
| 5537 { | |
| 5538 Lisp_Object val; | |
| 5539 int speccount = specpdl_depth(); | |
| 5540 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5541 set_buffer_internal (buf); | |
| 5542 val = call1 (fn, arg0); | |
| 771 | 5543 unbind_to (speccount); |
| 428 | 5544 return val; |
| 5545 } | |
| 5546 } | |
| 5547 | |
| 5548 Lisp_Object | |
| 5549 call2_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5550 Lisp_Object arg0, Lisp_Object arg1) | |
| 5551 { | |
| 5552 if (current_buffer == buf) | |
| 5553 return call2 (fn, arg0, arg1); | |
| 5554 else | |
| 5555 { | |
| 5556 Lisp_Object val; | |
| 5557 int speccount = specpdl_depth(); | |
| 5558 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5559 set_buffer_internal (buf); | |
| 5560 val = call2 (fn, arg0, arg1); | |
| 771 | 5561 unbind_to (speccount); |
| 428 | 5562 return val; |
| 5563 } | |
| 5564 } | |
| 5565 | |
| 5566 Lisp_Object | |
| 5567 call3_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5568 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2) | |
| 5569 { | |
| 5570 if (current_buffer == buf) | |
| 5571 return call3 (fn, arg0, arg1, arg2); | |
| 5572 else | |
| 5573 { | |
| 5574 Lisp_Object val; | |
| 5575 int speccount = specpdl_depth(); | |
| 5576 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5577 set_buffer_internal (buf); | |
| 5578 val = call3 (fn, arg0, arg1, arg2); | |
| 771 | 5579 unbind_to (speccount); |
| 428 | 5580 return val; |
| 5581 } | |
| 5582 } | |
| 5583 | |
| 5584 Lisp_Object | |
| 5585 call4_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5586 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5587 Lisp_Object arg3) | |
| 5588 { | |
| 5589 if (current_buffer == buf) | |
| 5590 return call4 (fn, arg0, arg1, arg2, arg3); | |
| 5591 else | |
| 5592 { | |
| 5593 Lisp_Object val; | |
| 5594 int speccount = specpdl_depth(); | |
| 5595 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5596 set_buffer_internal (buf); | |
| 5597 val = call4 (fn, arg0, arg1, arg2, arg3); | |
| 771 | 5598 unbind_to (speccount); |
| 428 | 5599 return val; |
| 5600 } | |
| 5601 } | |
| 5602 | |
| 5603 Lisp_Object | |
| 5604 eval_in_buffer (struct buffer *buf, Lisp_Object form) | |
| 5605 { | |
| 5606 if (current_buffer == buf) | |
| 5607 return Feval (form); | |
| 5608 else | |
| 5609 { | |
| 5610 Lisp_Object val; | |
| 5611 int speccount = specpdl_depth(); | |
| 5612 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5613 set_buffer_internal (buf); | |
| 5614 val = Feval (form); | |
| 771 | 5615 unbind_to (speccount); |
| 428 | 5616 return val; |
| 5617 } | |
| 5618 } | |
| 5619 | |
| 5620 | |
| 5621 /************************************************************************/ | |
| 5622 /* Error-catching front-ends to eval, funcall, apply */ | |
| 5623 /************************************************************************/ | |
| 5624 | |
| 853 | 5625 int |
| 5626 get_inhibit_flags (void) | |
| 5627 { | |
| 5628 return inhibit_flags; | |
| 5629 } | |
| 5630 | |
| 5631 void | |
| 2286 | 5632 check_allowed_operation (int what, Lisp_Object obj, Lisp_Object UNUSED (prop)) |
| 853 | 5633 { |
| 5634 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5635 { | |
| 5636 if (what == OPERATION_MODIFY_BUFFER_TEXT && BUFFERP (obj) | |
| 5637 && NILP (memq_no_quit (obj, Vmodifiable_buffers))) | |
| 5638 invalid_change | |
| 5639 ("Modification of this buffer not currently permitted", obj); | |
| 5640 } | |
| 5641 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5642 { | |
| 5643 if (what == OPERATION_DELETE_OBJECT | |
| 5644 && (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5645 || CONSOLEP (obj)) | |
| 5646 && NILP (memq_no_quit (obj, Vdeletable_permanent_display_objects))) | |
| 5647 invalid_change | |
| 5648 ("Deletion of this object not currently permitted", obj); | |
| 5649 } | |
| 5650 } | |
| 5651 | |
| 5652 void | |
| 5653 note_object_created (Lisp_Object obj) | |
| 5654 { | |
| 5655 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5656 { | |
| 5657 if (BUFFERP (obj)) | |
| 5658 Vmodifiable_buffers = Fcons (obj, Vmodifiable_buffers); | |
| 5659 } | |
| 5660 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5661 { | |
| 5662 if (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5663 || CONSOLEP (obj)) | |
| 5664 Vdeletable_permanent_display_objects = | |
| 5665 Fcons (obj, Vdeletable_permanent_display_objects); | |
| 5666 } | |
| 5667 } | |
| 5668 | |
| 5669 void | |
| 5670 note_object_deleted (Lisp_Object obj) | |
| 5671 { | |
| 5672 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5673 { | |
| 5674 if (BUFFERP (obj)) | |
| 5675 Vmodifiable_buffers = delq_no_quit (obj, Vmodifiable_buffers); | |
| 5676 } | |
| 5677 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5678 { | |
| 5679 if (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5680 || CONSOLEP (obj)) | |
| 5681 Vdeletable_permanent_display_objects = | |
| 5682 delq_no_quit (obj, Vdeletable_permanent_display_objects); | |
| 5683 } | |
| 5684 } | |
| 5685 | |
| 5686 struct call_trapping_problems | |
| 5687 { | |
| 5688 Lisp_Object catchtag; | |
| 5689 Lisp_Object error_conditions; | |
| 5690 Lisp_Object data; | |
| 5691 Lisp_Object backtrace; | |
| 5692 Lisp_Object warning_class; | |
| 5693 | |
| 867 | 5694 const CIbyte *warning_string; |
| 853 | 5695 Lisp_Object (*fun) (void *); |
| 5696 void *arg; | |
| 5697 }; | |
| 428 | 5698 |
| 2532 | 5699 static Lisp_Object |
| 5700 maybe_get_trapping_problems_backtrace (void) | |
| 5701 { | |
| 5702 Lisp_Object backtrace; | |
| 853 | 5703 |
| 1123 | 5704 if (!(inhibit_flags & INHIBIT_WARNING_ISSUE) |
| 2532 | 5705 && !warning_will_be_discarded (current_warning_level ())) |
| 428 | 5706 { |
| 1333 | 5707 struct gcpro gcpro1; |
| 5708 Lisp_Object lstream = Qnil; | |
| 5709 int speccount = specpdl_depth (); | |
| 5710 | |
| 853 | 5711 /* We're no longer protected against errors or quit here, so at |
| 5712 least let's temporarily inhibit quit. We definitely do not | |
| 5713 want to inhibit quit during the calling of the function | |
| 5714 itself!!!!!!!!!!! */ | |
| 5715 | |
| 5716 specbind (Qinhibit_quit, Qt); | |
| 5717 | |
| 5718 GCPRO1 (lstream); | |
| 5719 lstream = make_resizing_buffer_output_stream (); | |
| 5720 Fbacktrace (lstream, Qt); | |
| 5721 Lstream_flush (XLSTREAM (lstream)); | |
| 2532 | 5722 backtrace = resizing_buffer_to_lisp_string (XLSTREAM (lstream)); |
| 853 | 5723 Lstream_delete (XLSTREAM (lstream)); |
| 5724 UNGCPRO; | |
| 5725 | |
| 5726 unbind_to (speccount); | |
| 428 | 5727 } |
| 853 | 5728 else |
| 2532 | 5729 backtrace = Qnil; |
| 5730 | |
| 5731 return backtrace; | |
| 5732 } | |
| 5733 | |
| 5734 static DECLARE_DOESNT_RETURN_TYPE | |
| 5735 (Lisp_Object, flagged_a_squirmer (Lisp_Object, Lisp_Object, Lisp_Object)); | |
| 5736 | |
| 5737 static DOESNT_RETURN_TYPE (Lisp_Object) | |
| 5738 flagged_a_squirmer (Lisp_Object error_conditions, Lisp_Object data, | |
| 5739 Lisp_Object opaque) | |
| 5740 { | |
| 5741 struct call_trapping_problems *p = | |
| 5742 (struct call_trapping_problems *) get_opaque_ptr (opaque); | |
| 5743 | |
| 5744 if (!EQ (error_conditions, Qquit)) | |
| 5745 p->backtrace = maybe_get_trapping_problems_backtrace (); | |
| 5746 else | |
| 853 | 5747 p->backtrace = Qnil; |
| 5748 p->error_conditions = error_conditions; | |
| 5749 p->data = data; | |
| 5750 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5751 throw_or_bomb_out (p->catchtag, Qnil, 0, Qnil, Qnil); |
| 2268 | 5752 RETURN_NOT_REACHED (Qnil); |
| 853 | 5753 } |
| 5754 | |
| 5755 static Lisp_Object | |
| 5756 call_trapping_problems_2 (Lisp_Object opaque) | |
| 5757 { | |
| 5758 struct call_trapping_problems *p = | |
| 5759 (struct call_trapping_problems *) get_opaque_ptr (opaque); | |
| 5760 | |
| 5761 return (p->fun) (p->arg); | |
| 428 | 5762 } |
| 5763 | |
| 5764 static Lisp_Object | |
| 853 | 5765 call_trapping_problems_1 (Lisp_Object opaque) |
| 5766 { | |
| 5767 return call_with_condition_handler (flagged_a_squirmer, opaque, | |
| 5768 call_trapping_problems_2, opaque); | |
| 5769 } | |
| 5770 | |
| 1333 | 5771 static void |
| 5772 issue_call_trapping_problems_warning (Lisp_Object warning_class, | |
| 5773 const CIbyte *warning_string, | |
| 5774 struct call_trapping_problems_result *p) | |
| 5775 { | |
| 5776 if (!warning_will_be_discarded (current_warning_level ())) | |
| 5777 { | |
| 5778 int depth = specpdl_depth (); | |
| 5779 | |
| 5780 /* We're no longer protected against errors or quit here, so at | |
| 5781 least let's temporarily inhibit quit. */ | |
| 5782 specbind (Qinhibit_quit, Qt); | |
| 5783 | |
| 5784 if (p->caught_throw) | |
| 5785 { | |
| 5786 Lisp_Object errstr = | |
| 5787 emacs_sprintf_string_lisp | |
| 2532 | 5788 ("%s: Attempt to throw outside of function:" |
| 5789 "To catch `%s' with value `%s'\n\nBacktrace follows:\n\n%s", | |
| 2725 | 5790 Qnil, 4, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
5791 build_msg_cistring (warning_string ? warning_string : "error"), |
| 2532 | 5792 p->thrown_tag, p->thrown_value, p->backtrace); |
| 1333 | 5793 warn_when_safe_lispobj (Qerror, current_warning_level (), errstr); |
| 5794 } | |
| 2421 | 5795 else if (p->caught_error && !EQ (p->error_conditions, Qquit)) |
| 1333 | 5796 { |
| 5797 Lisp_Object errstr; | |
| 5798 /* #### This should call | |
| 5799 (with-output-to-string (display-error (cons error_conditions | |
| 5800 data)) | |
| 5801 but that stuff is all in Lisp currently. */ | |
| 5802 errstr = | |
| 5803 emacs_sprintf_string_lisp | |
| 5804 ("%s: (%s %s)\n\nBacktrace follows:\n\n%s", | |
| 5805 Qnil, 4, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
5806 build_msg_cistring (warning_string ? warning_string : "error"), |
| 1333 | 5807 p->error_conditions, p->data, p->backtrace); |
| 5808 | |
| 5809 warn_when_safe_lispobj (warning_class, current_warning_level (), | |
| 5810 errstr); | |
| 5811 } | |
| 5812 | |
| 5813 unbind_to (depth); | |
| 5814 } | |
| 5815 } | |
| 5816 | |
| 1318 | 5817 /* Turn on the trapping flags in FLAGS -- see call_trapping_problems(). |
| 5818 This cannot handle INTERNAL_INHIBIT_THROWS() or INTERNAL_INHIBIT_ERRORS | |
| 5819 (because they ultimately boil down to a setjmp()!) -- you must directly | |
| 5820 use call_trapping_problems() for that. Turn the flags off with | |
| 5821 unbind_to(). Returns the "canonicalized" flags (particularly in the | |
| 5822 case of INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY, which is shorthand for | |
| 5823 various other flags). */ | |
| 5824 | |
| 5825 int | |
| 5826 set_trapping_problems_flags (int flags) | |
| 5827 { | |
| 5828 int new_inhibit_flags; | |
| 5829 | |
| 5830 if (flags & INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY) | |
| 5831 flags |= INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | |
| 5832 | INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION | |
| 5833 | INHIBIT_ENTERING_DEBUGGER | |
| 5834 | INHIBIT_WARNING_ISSUE | |
| 5835 | INHIBIT_GC; | |
| 5836 | |
| 5837 new_inhibit_flags = inhibit_flags | flags; | |
| 5838 if (new_inhibit_flags != inhibit_flags) | |
| 5839 internal_bind_int (&inhibit_flags, new_inhibit_flags); | |
| 5840 | |
| 5841 if (flags & INHIBIT_QUIT) | |
| 5842 specbind (Qinhibit_quit, Qt); | |
| 5843 | |
| 5844 if (flags & UNINHIBIT_QUIT) | |
| 5845 begin_do_check_for_quit (); | |
| 5846 | |
| 5847 if (flags & INHIBIT_GC) | |
| 5848 begin_gc_forbidden (); | |
| 5849 | |
| 5850 /* #### If we have nested calls to call_trapping_problems(), and the | |
| 5851 inner one creates some buffers/etc., should the outer one be able | |
| 5852 to delete them? I think so, but it means we need to combine rather | |
| 5853 than just reset the value. */ | |
| 5854 if (flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5855 internal_bind_lisp_object (&Vdeletable_permanent_display_objects, Qnil); | |
| 5856 | |
| 5857 if (flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5858 internal_bind_lisp_object (&Vmodifiable_buffers, Qnil); | |
| 5859 | |
| 5860 return flags; | |
| 5861 } | |
| 5862 | |
| 853 | 5863 /* This is equivalent to (*fun) (arg), except that various conditions |
| 5864 can be trapped or inhibited, according to FLAGS. | |
| 5865 | |
| 5866 If FLAGS does not contain NO_INHIBIT_ERRORS, when an error occurs, | |
| 5867 the error is caught and a warning is issued, specifying the | |
| 5868 specific error that occurred and a backtrace. In that case, | |
| 5869 WARNING_STRING should be given, and will be printed at the | |
| 5870 beginning of the error to indicate where the error occurred. | |
| 5871 | |
| 5872 If FLAGS does not contain NO_INHIBIT_THROWS, all attempts to | |
| 5873 `throw' out of the function being called are trapped, and a warning | |
| 5874 issued. (Again, WARNING_STRING should be given.) | |
| 5875 | |
| 2367 | 5876 If FLAGS contains INHIBIT_WARNING_ISSUE, no warnings are issued; |
| 853 | 5877 this applies to recursive invocations of call_trapping_problems, too. |
| 5878 | |
| 1333 | 5879 If FLAGS contains POSTPONE_WARNING_ISSUE, no warnings are issued; |
| 5880 but values useful for generating a warning are still computed (in | |
| 5881 particular, the backtrace), so that the calling function can issue | |
| 5882 a warning. | |
| 5883 | |
| 853 | 5884 If FLAGS contains ISSUE_WARNINGS_AT_DEBUG_LEVEL, warnings will be |
| 5885 issued, but at level `debug', which normally is below the minimum | |
| 5886 specified by `log-warning-minimum-level', meaning such warnings will | |
| 5887 be ignored entirely. The user can change this variable, however, | |
| 5888 to see the warnings.) | |
| 5889 | |
| 5890 Note: If neither of NO_INHIBIT_THROWS or NO_INHIBIT_ERRORS is | |
| 5891 given, you are *guaranteed* that there will be no non-local exits | |
| 5892 out of this function. | |
| 5893 | |
| 5894 If FLAGS contains INHIBIT_QUIT, QUIT using C-g is inhibited. (This | |
| 5895 is *rarely* a good idea. Unless you use NO_INHIBIT_ERRORS, QUIT is | |
| 5896 automatically caught as well, and treated as an error; you can | |
| 5897 check for this using EQ (problems->error_conditions, Qquit). | |
| 5898 | |
| 5899 If FLAGS contains UNINHIBIT_QUIT, QUIT checking will be explicitly | |
| 5900 turned on. (It will abort the code being called, but will still be | |
| 5901 trapped and reported as an error, unless NO_INHIBIT_ERRORS is | |
| 5902 given.) This is useful when QUIT checking has been turned off by a | |
| 5903 higher-level caller. | |
| 5904 | |
| 5905 If FLAGS contains INHIBIT_GC, garbage collection is inhibited. | |
| 1123 | 5906 This is useful for Lisp called within redisplay, for example. |
| 853 | 5907 |
| 5908 If FLAGS contains INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION, | |
| 5909 Lisp code is not allowed to delete any window, buffers, frames, devices, | |
| 5910 or consoles that were already in existence at the time this function | |
| 5911 was called. (However, it's perfectly legal for code to create a new | |
| 5912 buffer and then delete it.) | |
| 5913 | |
| 5914 #### It might be useful to have a flag that inhibits deletion of a | |
| 5915 specific permanent display object and everything it's attached to | |
| 5916 (e.g. a window, and the buffer, frame, device, and console it's | |
| 5917 attached to. | |
| 5918 | |
| 5919 If FLAGS contains INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION, Lisp | |
| 5920 code is not allowed to modify the text of any buffers that were | |
| 5921 already in existence at the time this function was called. | |
| 5922 (However, it's perfectly legal for code to create a new buffer and | |
| 5923 then modify its text.) | |
| 5924 | |
| 5925 [These last two flags are implemented using global variables | |
| 5926 Vdeletable_permanent_display_objects and Vmodifiable_buffers, | |
| 5927 which keep track of a list of all buffers or permanent display | |
| 5928 objects created since the last time one of these flags was set. | |
| 5929 The code that deletes buffers, etc. and modifies buffers checks | |
| 5930 | |
| 5931 (1) if the corresponding flag is set (through the global variable | |
| 5932 inhibit_flags or its accessor function get_inhibit_flags()), and | |
| 5933 | |
| 5934 (2) if the object to be modified or deleted is not in the | |
| 5935 appropriate list. | |
| 5936 | |
| 5937 If so, it signals an error. | |
| 5938 | |
| 5939 Recursive calls to call_trapping_problems() are allowed. In | |
| 5940 the case of the two flags mentioned above, the current values | |
| 5941 of the global variables are stored in an unwind-protect, and | |
| 5942 they're reset to nil.] | |
| 5943 | |
| 5944 If FLAGS contains INHIBIT_ENTERING_DEBUGGER, the debugger will not | |
| 5945 be entered if an error occurs inside the Lisp code being called, | |
| 5946 even when the user has requested an error. In such case, a warning | |
| 5947 is issued stating that access to the debugger is denied, unless | |
| 5948 INHIBIT_WARNING_ISSUE has also been supplied. This is useful when | |
| 5949 calling Lisp code inside redisplay, in menu callbacks, etc. because | |
| 5950 in such cases either the display is in an inconsistent state or | |
| 5951 doing window operations is explicitly forbidden by the OS, and the | |
| 5952 debugger would causes visual changes on the screen and might create | |
| 5953 another frame. | |
| 5954 | |
| 5955 If FLAGS contains INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY, no | |
| 5956 changes of any sort to extents, faces, glyphs, buffer text, | |
| 5957 specifiers relating to display, other variables relating to | |
| 5958 display, splitting, deleting, or resizing windows or frames, | |
| 5959 deleting buffers, windows, frames, devices, or consoles, etc. is | |
| 5960 allowed. This is for things called absolutely in the middle of | |
| 5961 redisplay, which expects things to be *exactly* the same after the | |
| 5962 call as before. This isn't completely implemented and needs to be | |
| 5963 thought out some more to determine exactly what its semantics are. | |
| 5964 For the moment, turning on this flag also turns on | |
| 5965 | |
| 5966 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | |
| 5967 INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION | |
| 5968 INHIBIT_ENTERING_DEBUGGER | |
| 5969 INHIBIT_WARNING_ISSUE | |
| 5970 INHIBIT_GC | |
| 5971 | |
| 5972 #### The following five flags are defined, but unimplemented: | |
| 5973 | |
| 5974 #define INHIBIT_EXISTING_CODING_SYSTEM_DELETION (1<<6) | |
| 5975 #define INHIBIT_EXISTING_CHARSET_DELETION (1<<7) | |
| 5976 #define INHIBIT_PERMANENT_DISPLAY_OBJECT_CREATION (1<<8) | |
| 5977 #define INHIBIT_CODING_SYSTEM_CREATION (1<<9) | |
| 5978 #define INHIBIT_CHARSET_CREATION (1<<10) | |
| 5979 | |
| 5980 FLAGS containing CALL_WITH_SUSPENDED_ERRORS is a sign that | |
| 5981 call_with_suspended_errors() was invoked. This exists only for | |
| 5982 debugging purposes -- often we want to break when a signal happens, | |
| 5983 but ignore signals from call_with_suspended_errors(), because they | |
| 5984 occur often and for legitimate reasons. | |
| 5985 | |
| 5986 If PROBLEM is non-zero, it should be a pointer to a structure into | |
| 5987 which exact information about any occurring problems (either an | |
| 5988 error or an attempted throw past this boundary). | |
| 5989 | |
| 5990 If a problem occurred and aborted operation (error, quit, or | |
| 5991 invalid throw), Qunbound is returned. Otherwise the return value | |
| 5992 from the call to (*fun) (arg) is returned. */ | |
| 5993 | |
| 5994 Lisp_Object | |
| 5995 call_trapping_problems (Lisp_Object warning_class, | |
| 867 | 5996 const CIbyte *warning_string, |
| 853 | 5997 int flags, |
| 5998 struct call_trapping_problems_result *problem, | |
| 5999 Lisp_Object (*fun) (void *), | |
| 6000 void *arg) | |
| 6001 { | |
| 1318 | 6002 int speccount = specpdl_depth (); |
| 853 | 6003 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; |
| 6004 struct call_trapping_problems package; | |
| 1333 | 6005 struct call_trapping_problems_result real_problem; |
| 2532 | 6006 Lisp_Object opaque, thrown_tag, tem, thrown_backtrace; |
| 853 | 6007 int thrown = 0; |
| 6008 | |
| 6009 assert (SYMBOLP (warning_class)); /* sanity-check */ | |
| 6010 assert (!NILP (warning_class)); | |
| 6011 | |
| 6012 flags ^= INTERNAL_INHIBIT_ERRORS | INTERNAL_INHIBIT_THROWS; | |
| 6013 | |
| 6014 package.warning_class = warning_class; | |
| 6015 package.warning_string = warning_string; | |
| 6016 package.fun = fun; | |
| 6017 package.arg = arg; | |
| 6018 package.catchtag = | |
| 6019 flags & INTERNAL_INHIBIT_THROWS ? Vcatch_everything_tag : | |
| 6020 flags & INTERNAL_INHIBIT_ERRORS ? make_opaque_ptr (0) : | |
| 6021 Qnil; | |
| 6022 package.error_conditions = Qnil; | |
| 6023 package.data = Qnil; | |
| 6024 package.backtrace = Qnil; | |
| 6025 | |
| 1318 | 6026 flags = set_trapping_problems_flags (flags); |
| 853 | 6027 |
| 6028 if (flags & (INTERNAL_INHIBIT_THROWS | INTERNAL_INHIBIT_ERRORS)) | |
| 6029 opaque = make_opaque_ptr (&package); | |
| 6030 else | |
| 6031 opaque = Qnil; | |
| 6032 | |
| 6033 GCPRO5 (package.catchtag, package.error_conditions, package.data, | |
| 6034 package.backtrace, opaque); | |
| 6035 | |
| 6036 if (flags & INTERNAL_INHIBIT_ERRORS) | |
| 6037 /* We need a catch so that our condition-handler can throw back here | |
| 6038 after printing the warning. (We print the warning in the stack | |
| 6039 context of the error, so we can get a backtrace.) */ | |
| 6040 tem = internal_catch (package.catchtag, call_trapping_problems_1, opaque, | |
| 2532 | 6041 &thrown, &thrown_tag, &thrown_backtrace); |
| 853 | 6042 else if (flags & INTERNAL_INHIBIT_THROWS) |
| 6043 /* We skip over the first wrapper, which traps errors. */ | |
| 6044 tem = internal_catch (package.catchtag, call_trapping_problems_2, opaque, | |
| 2532 | 6045 &thrown, &thrown_tag, &thrown_backtrace); |
| 853 | 6046 else |
| 6047 /* Nothing special. */ | |
| 6048 tem = (fun) (arg); | |
| 6049 | |
| 1333 | 6050 if (!problem) |
| 6051 problem = &real_problem; | |
| 6052 | |
| 6053 if (!thrown) | |
| 853 | 6054 { |
| 1333 | 6055 problem->caught_error = 0; |
| 6056 problem->caught_throw = 0; | |
| 6057 problem->error_conditions = Qnil; | |
| 6058 problem->data = Qnil; | |
| 6059 problem->backtrace = Qnil; | |
| 6060 problem->thrown_tag = Qnil; | |
| 6061 problem->thrown_value = Qnil; | |
| 853 | 6062 } |
| 1333 | 6063 else if (EQ (thrown_tag, package.catchtag)) |
| 853 | 6064 { |
| 1333 | 6065 problem->caught_error = 1; |
| 6066 problem->caught_throw = 0; | |
| 6067 problem->error_conditions = package.error_conditions; | |
| 6068 problem->data = package.data; | |
| 6069 problem->backtrace = package.backtrace; | |
| 6070 problem->thrown_tag = Qnil; | |
| 6071 problem->thrown_value = Qnil; | |
| 853 | 6072 } |
| 1333 | 6073 else |
| 6074 { | |
| 6075 problem->caught_error = 0; | |
| 6076 problem->caught_throw = 1; | |
| 6077 problem->error_conditions = Qnil; | |
| 6078 problem->data = Qnil; | |
| 2532 | 6079 problem->backtrace = thrown_backtrace; |
| 1333 | 6080 problem->thrown_tag = thrown_tag; |
| 6081 problem->thrown_value = tem; | |
| 6082 } | |
| 6083 | |
| 6084 if (!(flags & INHIBIT_WARNING_ISSUE) && !(flags & POSTPONE_WARNING_ISSUE)) | |
| 6085 issue_call_trapping_problems_warning (warning_class, warning_string, | |
| 6086 problem); | |
| 853 | 6087 |
| 6088 if (!NILP (package.catchtag) && | |
| 6089 !EQ (package.catchtag, Vcatch_everything_tag)) | |
| 6090 free_opaque_ptr (package.catchtag); | |
| 6091 | |
| 6092 if (!NILP (opaque)) | |
| 6093 free_opaque_ptr (opaque); | |
| 6094 | |
| 6095 unbind_to (speccount); | |
| 6096 RETURN_UNGCPRO (thrown ? Qunbound : tem); | |
| 6097 } | |
| 6098 | |
| 6099 struct va_call_trapping_problems | |
| 6100 { | |
| 6101 lisp_fn_t fun; | |
| 6102 int nargs; | |
| 6103 Lisp_Object *args; | |
| 6104 }; | |
| 6105 | |
| 6106 static Lisp_Object | |
| 6107 va_call_trapping_problems_1 (void *ai_mi_madre) | |
| 6108 { | |
| 6109 struct va_call_trapping_problems *ai_no_corrida = | |
| 6110 (struct va_call_trapping_problems *) ai_mi_madre; | |
| 6111 Lisp_Object pegar_no_bumbum; | |
| 6112 | |
| 6113 PRIMITIVE_FUNCALL (pegar_no_bumbum, ai_no_corrida->fun, | |
| 6114 ai_no_corrida->args, ai_no_corrida->nargs); | |
| 6115 return pegar_no_bumbum; | |
| 6116 } | |
| 6117 | |
| 6118 /* #### document me. */ | |
| 6119 | |
| 6120 Lisp_Object | |
| 6121 va_call_trapping_problems (Lisp_Object warning_class, | |
| 867 | 6122 const CIbyte *warning_string, |
| 853 | 6123 int flags, |
| 6124 struct call_trapping_problems_result *problem, | |
| 6125 lisp_fn_t fun, int nargs, ...) | |
| 6126 { | |
| 6127 va_list vargs; | |
| 6128 Lisp_Object args[20]; | |
| 6129 int i; | |
| 6130 struct va_call_trapping_problems fazer_invocacao_atrapalhando_problemas; | |
| 6131 struct gcpro gcpro1; | |
| 6132 | |
| 6133 assert (nargs >= 0 && nargs < 20); | |
| 6134 | |
| 6135 va_start (vargs, nargs); | |
| 6136 for (i = 0; i < nargs; i++) | |
| 6137 args[i] = va_arg (vargs, Lisp_Object); | |
| 6138 va_end (vargs); | |
| 6139 | |
| 6140 fazer_invocacao_atrapalhando_problemas.fun = fun; | |
| 6141 fazer_invocacao_atrapalhando_problemas.nargs = nargs; | |
| 6142 fazer_invocacao_atrapalhando_problemas.args = args; | |
| 6143 | |
| 6144 GCPRO1_ARRAY (args, nargs); | |
| 6145 RETURN_UNGCPRO | |
| 6146 (call_trapping_problems | |
| 6147 (warning_class, warning_string, flags, problem, | |
| 6148 va_call_trapping_problems_1, &fazer_invocacao_atrapalhando_problemas)); | |
| 6149 } | |
| 6150 | |
| 6151 /* this is an older interface, barely different from | |
| 6152 va_call_trapping_problems. | |
| 6153 | |
| 6154 #### eliminate this or at least merge the ERROR_BEHAVIOR stuff into | |
| 6155 va_call_trapping_problems(). */ | |
| 6156 | |
| 6157 Lisp_Object | |
| 6158 call_with_suspended_errors (lisp_fn_t fun, Lisp_Object retval, | |
| 1204 | 6159 Lisp_Object class_, Error_Behavior errb, |
| 853 | 6160 int nargs, ...) |
| 6161 { | |
| 6162 va_list vargs; | |
| 6163 Lisp_Object args[20]; | |
| 6164 int i; | |
| 6165 struct va_call_trapping_problems fazer_invocacao_atrapalhando_problemas; | |
| 6166 int flags; | |
| 6167 struct gcpro gcpro1; | |
| 6168 | |
| 1204 | 6169 assert (SYMBOLP (class_)); /* sanity-check */ |
| 6170 assert (!NILP (class_)); | |
| 853 | 6171 assert (nargs >= 0 && nargs < 20); |
| 6172 | |
| 6173 va_start (vargs, nargs); | |
| 6174 for (i = 0; i < nargs; i++) | |
| 6175 args[i] = va_arg (vargs, Lisp_Object); | |
| 6176 va_end (vargs); | |
| 6177 | |
| 6178 /* If error-checking is not disabled, just call the function. */ | |
| 6179 | |
| 6180 if (ERRB_EQ (errb, ERROR_ME)) | |
| 6181 { | |
| 6182 Lisp_Object val; | |
| 6183 PRIMITIVE_FUNCALL (val, fun, args, nargs); | |
| 6184 return val; | |
| 6185 } | |
| 6186 | |
| 6187 if (ERRB_EQ (errb, ERROR_ME_NOT)) /* person wants no warnings */ | |
| 6188 flags = INHIBIT_WARNING_ISSUE | INHIBIT_ENTERING_DEBUGGER; | |
| 6189 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) | |
| 6190 flags = ISSUE_WARNINGS_AT_DEBUG_LEVEL | INHIBIT_ENTERING_DEBUGGER; | |
| 6191 else | |
| 6192 { | |
| 6193 assert (ERRB_EQ (errb, ERROR_ME_WARN)); | |
| 6194 flags = INHIBIT_ENTERING_DEBUGGER; | |
| 6195 } | |
| 6196 | |
| 6197 flags |= CALL_WITH_SUSPENDED_ERRORS; | |
| 6198 | |
| 6199 fazer_invocacao_atrapalhando_problemas.fun = fun; | |
| 6200 fazer_invocacao_atrapalhando_problemas.nargs = nargs; | |
| 6201 fazer_invocacao_atrapalhando_problemas.args = args; | |
| 6202 | |
| 6203 GCPRO1_ARRAY (args, nargs); | |
| 6204 { | |
| 6205 Lisp_Object its_way_too_goddamn_late = | |
| 6206 call_trapping_problems | |
| 1204 | 6207 (class_, 0, flags, 0, va_call_trapping_problems_1, |
| 853 | 6208 &fazer_invocacao_atrapalhando_problemas); |
| 6209 UNGCPRO; | |
| 6210 if (UNBOUNDP (its_way_too_goddamn_late)) | |
| 6211 return retval; | |
| 6212 else | |
| 6213 return its_way_too_goddamn_late; | |
| 6214 } | |
| 6215 } | |
| 6216 | |
| 6217 struct calln_trapping_problems | |
| 6218 { | |
| 6219 int nargs; | |
| 6220 Lisp_Object *args; | |
| 6221 }; | |
| 6222 | |
| 6223 static Lisp_Object | |
| 6224 calln_trapping_problems_1 (void *puta) | |
| 6225 { | |
| 6226 struct calln_trapping_problems *p = (struct calln_trapping_problems *) puta; | |
| 6227 | |
| 6228 return Ffuncall (p->nargs, p->args); | |
| 428 | 6229 } |
| 6230 | |
| 6231 static Lisp_Object | |
| 853 | 6232 calln_trapping_problems (Lisp_Object warning_class, |
| 867 | 6233 const CIbyte *warning_string, int flags, |
| 853 | 6234 struct call_trapping_problems_result *problem, |
| 6235 int nargs, Lisp_Object *args) | |
| 6236 { | |
| 6237 struct calln_trapping_problems foo; | |
| 6238 struct gcpro gcpro1; | |
| 6239 | |
| 6240 if (SYMBOLP (args[0])) | |
| 6241 { | |
| 6242 Lisp_Object tem = XSYMBOL (args[0])->function; | |
| 6243 if (NILP (tem) || UNBOUNDP (tem)) | |
| 6244 { | |
| 6245 if (problem) | |
| 6246 { | |
| 6247 problem->caught_error = 0; | |
| 6248 problem->caught_throw = 0; | |
| 6249 problem->error_conditions = Qnil; | |
| 6250 problem->data = Qnil; | |
| 6251 problem->backtrace = Qnil; | |
| 6252 problem->thrown_tag = Qnil; | |
| 6253 problem->thrown_value = Qnil; | |
| 6254 } | |
| 6255 return Qnil; | |
| 6256 } | |
| 6257 } | |
| 6258 | |
| 6259 foo.nargs = nargs; | |
| 6260 foo.args = args; | |
| 6261 | |
| 6262 GCPRO1_ARRAY (args, nargs); | |
| 6263 RETURN_UNGCPRO (call_trapping_problems (warning_class, warning_string, | |
| 6264 flags, problem, | |
| 6265 calln_trapping_problems_1, | |
| 6266 &foo)); | |
| 6267 } | |
| 6268 | |
| 6269 /* #### fix these functions to follow the calling convention of | |
| 6270 call_trapping_problems! */ | |
| 6271 | |
| 6272 Lisp_Object | |
| 867 | 6273 call0_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6274 int flags) |
| 6275 { | |
| 6276 return calln_trapping_problems (Qerror, warning_string, flags, 0, 1, | |
| 6277 &function); | |
| 428 | 6278 } |
| 6279 | |
| 6280 Lisp_Object | |
| 867 | 6281 call1_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6282 Lisp_Object object, int flags) |
| 6283 { | |
| 6284 Lisp_Object args[2]; | |
| 6285 | |
| 6286 args[0] = function; | |
| 6287 args[1] = object; | |
| 6288 | |
| 6289 return calln_trapping_problems (Qerror, warning_string, flags, 0, 2, | |
| 6290 args); | |
| 6291 } | |
| 6292 | |
| 6293 Lisp_Object | |
| 867 | 6294 call2_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6295 Lisp_Object object1, Lisp_Object object2, |
| 6296 int flags) | |
| 6297 { | |
| 6298 Lisp_Object args[3]; | |
| 6299 | |
| 6300 args[0] = function; | |
| 6301 args[1] = object1; | |
| 6302 args[2] = object2; | |
| 6303 | |
| 6304 return calln_trapping_problems (Qerror, warning_string, flags, 0, 3, | |
| 6305 args); | |
| 6306 } | |
| 6307 | |
| 6308 Lisp_Object | |
| 867 | 6309 call3_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6310 Lisp_Object object1, Lisp_Object object2, |
| 6311 Lisp_Object object3, int flags) | |
| 6312 { | |
| 6313 Lisp_Object args[4]; | |
| 6314 | |
| 6315 args[0] = function; | |
| 6316 args[1] = object1; | |
| 6317 args[2] = object2; | |
| 6318 args[3] = object3; | |
| 6319 | |
| 6320 return calln_trapping_problems (Qerror, warning_string, flags, 0, 4, | |
| 6321 args); | |
| 6322 } | |
| 6323 | |
| 6324 Lisp_Object | |
| 867 | 6325 call4_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6326 Lisp_Object object1, Lisp_Object object2, |
| 6327 Lisp_Object object3, Lisp_Object object4, | |
| 6328 int flags) | |
| 6329 { | |
| 6330 Lisp_Object args[5]; | |
| 6331 | |
| 6332 args[0] = function; | |
| 6333 args[1] = object1; | |
| 6334 args[2] = object2; | |
| 6335 args[3] = object3; | |
| 6336 args[4] = object4; | |
| 6337 | |
| 6338 return calln_trapping_problems (Qerror, warning_string, flags, 0, 5, | |
| 6339 args); | |
| 6340 } | |
| 6341 | |
| 6342 Lisp_Object | |
| 867 | 6343 call5_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6344 Lisp_Object object1, Lisp_Object object2, |
| 6345 Lisp_Object object3, Lisp_Object object4, | |
| 6346 Lisp_Object object5, int flags) | |
| 6347 { | |
| 6348 Lisp_Object args[6]; | |
| 6349 | |
| 6350 args[0] = function; | |
| 6351 args[1] = object1; | |
| 6352 args[2] = object2; | |
| 6353 args[3] = object3; | |
| 6354 args[4] = object4; | |
| 6355 args[5] = object5; | |
| 6356 | |
| 6357 return calln_trapping_problems (Qerror, warning_string, flags, 0, 6, | |
| 6358 args); | |
| 6359 } | |
| 6360 | |
| 6361 struct eval_in_buffer_trapping_problems | |
| 6362 { | |
| 6363 struct buffer *buf; | |
| 6364 Lisp_Object form; | |
| 6365 }; | |
| 6366 | |
| 6367 static Lisp_Object | |
| 6368 eval_in_buffer_trapping_problems_1 (void *arg) | |
| 6369 { | |
| 6370 struct eval_in_buffer_trapping_problems *p = | |
| 6371 (struct eval_in_buffer_trapping_problems *) arg; | |
| 6372 | |
| 6373 return eval_in_buffer (p->buf, p->form); | |
| 6374 } | |
| 6375 | |
| 6376 /* #### fix these functions to follow the calling convention of | |
| 6377 call_trapping_problems! */ | |
| 6378 | |
| 6379 Lisp_Object | |
| 867 | 6380 eval_in_buffer_trapping_problems (const CIbyte *warning_string, |
| 853 | 6381 struct buffer *buf, Lisp_Object form, |
| 6382 int flags) | |
| 6383 { | |
| 6384 struct eval_in_buffer_trapping_problems p; | |
| 6385 Lisp_Object buffer = wrap_buffer (buf); | |
| 428 | 6386 struct gcpro gcpro1, gcpro2; |
| 6387 | |
| 853 | 6388 GCPRO2 (buffer, form); |
| 6389 p.buf = buf; | |
| 6390 p.form = form; | |
| 6391 RETURN_UNGCPRO (call_trapping_problems (Qerror, warning_string, flags, 0, | |
| 6392 eval_in_buffer_trapping_problems_1, | |
| 6393 &p)); | |
| 6394 } | |
| 6395 | |
| 6396 Lisp_Object | |
| 1333 | 6397 run_hook_trapping_problems (Lisp_Object warning_class, |
| 853 | 6398 Lisp_Object hook_symbol, |
| 6399 int flags) | |
| 6400 { | |
| 1333 | 6401 return run_hook_with_args_trapping_problems (warning_class, 1, &hook_symbol, |
| 853 | 6402 RUN_HOOKS_TO_COMPLETION, |
| 6403 flags); | |
| 428 | 6404 } |
| 6405 | |
| 6406 static Lisp_Object | |
| 853 | 6407 safe_run_hook_trapping_problems_1 (void *puta) |
| 6408 { | |
| 5013 | 6409 Lisp_Object hook = GET_LISP_FROM_VOID (puta); |
| 853 | 6410 |
| 6411 run_hook (hook); | |
| 428 | 6412 return Qnil; |
| 6413 } | |
| 6414 | |
| 853 | 6415 /* Same as run_hook_trapping_problems() but also set the hook to nil |
| 6416 if an error occurs (but not a quit). */ | |
| 6417 | |
| 428 | 6418 Lisp_Object |
| 1333 | 6419 safe_run_hook_trapping_problems (Lisp_Object warning_class, |
| 6420 Lisp_Object hook_symbol, int flags) | |
| 853 | 6421 { |
| 428 | 6422 Lisp_Object tem; |
| 853 | 6423 struct gcpro gcpro1, gcpro2; |
| 6424 struct call_trapping_problems_result prob; | |
| 428 | 6425 |
| 6426 if (!initialized || preparing_for_armageddon) | |
| 6427 return Qnil; | |
| 6428 tem = find_symbol_value (hook_symbol); | |
| 6429 if (NILP (tem) || UNBOUNDP (tem)) | |
| 6430 return Qnil; | |
| 6431 | |
| 853 | 6432 GCPRO2 (hook_symbol, tem); |
| 1333 | 6433 tem = call_trapping_problems (Qerror, NULL, |
| 6434 flags | POSTPONE_WARNING_ISSUE, | |
| 853 | 6435 &prob, |
| 6436 safe_run_hook_trapping_problems_1, | |
| 5013 | 6437 STORE_LISP_IN_VOID (hook_symbol)); |
| 1333 | 6438 { |
| 6439 Lisp_Object hook_name = XSYMBOL_NAME (hook_symbol); | |
| 6440 Ibyte *hook_str = XSTRING_DATA (hook_name); | |
| 6441 Ibyte *err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); | |
| 6442 | |
| 6443 if (prob.caught_throw || (prob.caught_error && !EQ (prob.error_conditions, | |
| 6444 Qquit))) | |
| 6445 { | |
| 6446 Fset (hook_symbol, Qnil); | |
| 6447 qxesprintf (err, "Error in `%s' (resetting to nil)", hook_str); | |
| 6448 } | |
| 6449 else | |
| 6450 qxesprintf (err, "Quit in `%s'", hook_str); | |
| 6451 | |
| 6452 | |
| 6453 issue_call_trapping_problems_warning (warning_class, (CIbyte *) err, | |
| 6454 &prob); | |
| 6455 } | |
| 6456 | |
| 6457 UNGCPRO; | |
| 6458 return tem; | |
| 853 | 6459 } |
| 6460 | |
| 6461 struct run_hook_with_args_in_buffer_trapping_problems | |
| 6462 { | |
| 6463 struct buffer *buf; | |
| 6464 int nargs; | |
| 6465 Lisp_Object *args; | |
| 6466 enum run_hooks_condition cond; | |
| 6467 }; | |
| 6468 | |
| 6469 static Lisp_Object | |
| 6470 run_hook_with_args_in_buffer_trapping_problems_1 (void *puta) | |
| 6471 { | |
| 6472 struct run_hook_with_args_in_buffer_trapping_problems *porra = | |
| 6473 (struct run_hook_with_args_in_buffer_trapping_problems *) puta; | |
| 6474 | |
| 6475 return run_hook_with_args_in_buffer (porra->buf, porra->nargs, porra->args, | |
| 6476 porra->cond); | |
| 6477 } | |
| 6478 | |
| 6479 /* #### fix these functions to follow the calling convention of | |
| 6480 call_trapping_problems! */ | |
| 428 | 6481 |
| 6482 Lisp_Object | |
| 1333 | 6483 run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, |
| 853 | 6484 struct buffer *buf, int nargs, |
| 6485 Lisp_Object *args, | |
| 6486 enum run_hooks_condition cond, | |
| 6487 int flags) | |
| 6488 { | |
| 6489 Lisp_Object sym, val, ret; | |
| 6490 struct run_hook_with_args_in_buffer_trapping_problems diversity_and_distrust; | |
| 428 | 6491 struct gcpro gcpro1; |
| 1333 | 6492 Lisp_Object hook_name; |
| 6493 Ibyte *hook_str; | |
| 6494 Ibyte *err; | |
| 428 | 6495 |
| 6496 if (!initialized || preparing_for_armageddon) | |
| 853 | 6497 /* We need to bail out of here pronto. */ |
| 428 | 6498 return Qnil; |
| 6499 | |
| 853 | 6500 GCPRO1_ARRAY (args, nargs); |
| 6501 | |
| 6502 sym = args[0]; | |
| 6503 val = symbol_value_in_buffer (sym, wrap_buffer (buf)); | |
| 6504 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil); | |
| 6505 | |
| 6506 if (UNBOUNDP (val) || NILP (val)) | |
| 6507 RETURN_UNGCPRO (ret); | |
| 6508 | |
| 6509 diversity_and_distrust.buf = buf; | |
| 6510 diversity_and_distrust.nargs = nargs; | |
| 6511 diversity_and_distrust.args = args; | |
| 6512 diversity_and_distrust.cond = cond; | |
| 6513 | |
| 1333 | 6514 hook_name = XSYMBOL_NAME (args[0]); |
| 6515 hook_str = XSTRING_DATA (hook_name); | |
| 6516 err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); | |
| 6517 qxesprintf (err, "Error in `%s'", hook_str); | |
| 853 | 6518 RETURN_UNGCPRO |
| 6519 (call_trapping_problems | |
| 1333 | 6520 (warning_class, (CIbyte *) err, flags, 0, |
| 853 | 6521 run_hook_with_args_in_buffer_trapping_problems_1, |
| 6522 &diversity_and_distrust)); | |
| 428 | 6523 } |
| 6524 | |
| 6525 Lisp_Object | |
| 1333 | 6526 run_hook_with_args_trapping_problems (Lisp_Object warning_class, |
| 853 | 6527 int nargs, |
| 6528 Lisp_Object *args, | |
| 6529 enum run_hooks_condition cond, | |
| 6530 int flags) | |
| 6531 { | |
| 6532 return run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6533 (warning_class, current_buffer, nargs, args, cond, flags); |
| 428 | 6534 } |
| 6535 | |
| 6536 Lisp_Object | |
| 1333 | 6537 va_run_hook_with_args_trapping_problems (Lisp_Object warning_class, |
| 853 | 6538 Lisp_Object hook_var, |
| 6539 int nargs, ...) | |
| 6540 { | |
| 6541 /* This function can GC */ | |
| 6542 struct gcpro gcpro1; | |
| 6543 int i; | |
| 6544 va_list vargs; | |
| 6545 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 6546 int flags; | |
| 6547 | |
| 6548 va_start (vargs, nargs); | |
| 6549 funcall_args[0] = hook_var; | |
| 6550 for (i = 0; i < nargs; i++) | |
| 6551 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 6552 flags = va_arg (vargs, int); | |
| 6553 va_end (vargs); | |
| 6554 | |
| 6555 GCPRO1_ARRAY (funcall_args, nargs + 1); | |
| 6556 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6557 (warning_class, current_buffer, nargs + 1, funcall_args, |
| 853 | 6558 RUN_HOOKS_TO_COMPLETION, flags)); |
| 428 | 6559 } |
| 6560 | |
| 6561 Lisp_Object | |
| 1333 | 6562 va_run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, |
| 853 | 6563 struct buffer *buf, |
| 6564 Lisp_Object hook_var, | |
| 6565 int nargs, ...) | |
| 6566 { | |
| 6567 /* This function can GC */ | |
| 6568 struct gcpro gcpro1; | |
| 6569 int i; | |
| 6570 va_list vargs; | |
| 6571 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 6572 int flags; | |
| 6573 | |
| 6574 va_start (vargs, nargs); | |
| 6575 funcall_args[0] = hook_var; | |
| 6576 for (i = 0; i < nargs; i++) | |
| 6577 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 6578 flags = va_arg (vargs, int); | |
| 6579 va_end (vargs); | |
| 6580 | |
| 6581 GCPRO1_ARRAY (funcall_args, nargs + 1); | |
| 6582 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6583 (warning_class, buf, nargs + 1, funcall_args, |
| 853 | 6584 RUN_HOOKS_TO_COMPLETION, flags)); |
| 428 | 6585 } |
| 6586 | |
| 6587 | |
| 6588 /************************************************************************/ | |
| 6589 /* The special binding stack */ | |
| 771 | 6590 /* Most C code should simply use specbind() and unbind_to_1(). */ |
| 428 | 6591 /* When performance is critical, use the macros in backtrace.h. */ |
| 6592 /************************************************************************/ | |
| 6593 | |
| 6594 #define min_max_specpdl_size 400 | |
| 6595 | |
| 6596 void | |
| 647 | 6597 grow_specpdl (EMACS_INT reserved) |
| 6598 { | |
| 6599 EMACS_INT size_needed = specpdl_depth() + reserved; | |
| 428 | 6600 if (size_needed >= max_specpdl_size) |
| 6601 { | |
| 6602 if (max_specpdl_size < min_max_specpdl_size) | |
| 6603 max_specpdl_size = min_max_specpdl_size; | |
| 6604 if (size_needed >= max_specpdl_size) | |
| 6605 { | |
| 1951 | 6606 /* Leave room for some specpdl in the debugger. */ |
| 6607 max_specpdl_size = size_needed + 100; | |
| 6608 if (max_specpdl_size > specpdl_size) | |
| 6609 { | |
| 6610 specpdl_size = max_specpdl_size; | |
| 6611 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); | |
| 6612 specpdl_ptr = specpdl + specpdl_depth(); | |
| 6613 } | |
| 563 | 6614 signal_continuable_error |
| 6615 (Qstack_overflow, | |
| 6616 "Variable binding depth exceeds max-specpdl-size", Qunbound); | |
| 428 | 6617 } |
| 6618 } | |
| 6619 while (specpdl_size < size_needed) | |
| 6620 { | |
| 6621 specpdl_size *= 2; | |
| 6622 if (specpdl_size > max_specpdl_size) | |
| 6623 specpdl_size = max_specpdl_size; | |
| 6624 } | |
| 6625 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); | |
| 6626 specpdl_ptr = specpdl + specpdl_depth(); | |
| 853 | 6627 check_specbind_stack_sanity (); |
| 428 | 6628 } |
| 6629 | |
| 6630 | |
| 6631 /* Handle unbinding buffer-local variables */ | |
| 6632 static Lisp_Object | |
| 6633 specbind_unwind_local (Lisp_Object ovalue) | |
| 6634 { | |
| 6635 Lisp_Object current = Fcurrent_buffer (); | |
| 6636 Lisp_Object symbol = specpdl_ptr->symbol; | |
| 853 | 6637 Lisp_Object victim = ovalue; |
| 6638 Lisp_Object buf = get_buffer (XCAR (victim), 0); | |
| 6639 ovalue = XCDR (victim); | |
| 428 | 6640 |
| 6641 free_cons (victim); | |
| 6642 | |
| 6643 if (NILP (buf)) | |
| 6644 { | |
| 6645 /* Deleted buffer -- do nothing */ | |
| 6646 } | |
| 6647 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 0) | |
| 6648 { | |
| 6649 /* Was buffer-local when binding was made, now no longer is. | |
| 6650 * (kill-local-variable can do this.) | |
| 6651 * Do nothing in this case. | |
| 6652 */ | |
| 6653 } | |
| 6654 else if (EQ (buf, current)) | |
| 6655 Fset (symbol, ovalue); | |
| 6656 else | |
| 6657 { | |
| 6658 /* Urk! Somebody switched buffers */ | |
| 6659 struct gcpro gcpro1; | |
| 6660 GCPRO1 (current); | |
| 6661 Fset_buffer (buf); | |
| 6662 Fset (symbol, ovalue); | |
| 6663 Fset_buffer (current); | |
| 6664 UNGCPRO; | |
| 6665 } | |
| 6666 return symbol; | |
| 6667 } | |
| 6668 | |
| 6669 static Lisp_Object | |
| 6670 specbind_unwind_wasnt_local (Lisp_Object buffer) | |
| 6671 { | |
| 6672 Lisp_Object current = Fcurrent_buffer (); | |
| 6673 Lisp_Object symbol = specpdl_ptr->symbol; | |
| 6674 | |
| 6675 buffer = get_buffer (buffer, 0); | |
| 6676 if (NILP (buffer)) | |
| 6677 { | |
| 6678 /* Deleted buffer -- do nothing */ | |
| 6679 } | |
| 6680 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 0) | |
| 6681 { | |
| 6682 /* Was buffer-local when binding was made, now no longer is. | |
| 6683 * (kill-local-variable can do this.) | |
| 6684 * Do nothing in this case. | |
| 6685 */ | |
| 6686 } | |
| 6687 else if (EQ (buffer, current)) | |
| 6688 Fkill_local_variable (symbol); | |
| 6689 else | |
| 6690 { | |
| 6691 /* Urk! Somebody switched buffers */ | |
| 6692 struct gcpro gcpro1; | |
| 6693 GCPRO1 (current); | |
| 6694 Fset_buffer (buffer); | |
| 6695 Fkill_local_variable (symbol); | |
| 6696 Fset_buffer (current); | |
| 6697 UNGCPRO; | |
| 6698 } | |
| 6699 return symbol; | |
| 6700 } | |
| 6701 | |
| 6702 | |
| 6703 void | |
| 6704 specbind (Lisp_Object symbol, Lisp_Object value) | |
| 6705 { | |
| 6706 SPECBIND (symbol, value); | |
| 853 | 6707 |
| 6708 check_specbind_stack_sanity (); | |
| 428 | 6709 } |
| 6710 | |
| 6711 void | |
| 6712 specbind_magic (Lisp_Object symbol, Lisp_Object value) | |
| 6713 { | |
| 6714 int buffer_local = | |
| 6715 symbol_value_buffer_local_info (symbol, current_buffer); | |
| 6716 | |
| 6717 if (buffer_local == 0) | |
| 6718 { | |
| 6719 specpdl_ptr->old_value = find_symbol_value (symbol); | |
| 771 | 6720 specpdl_ptr->func = 0; /* Handled specially by unbind_to_1 */ |
| 428 | 6721 } |
| 6722 else if (buffer_local > 0) | |
| 6723 { | |
| 6724 /* Already buffer-local */ | |
| 6725 specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (), | |
| 6726 find_symbol_value (symbol)); | |
| 6727 specpdl_ptr->func = specbind_unwind_local; | |
| 6728 } | |
| 6729 else | |
| 6730 { | |
| 6731 /* About to become buffer-local */ | |
| 6732 specpdl_ptr->old_value = Fcurrent_buffer (); | |
| 6733 specpdl_ptr->func = specbind_unwind_wasnt_local; | |
| 6734 } | |
| 6735 | |
| 6736 specpdl_ptr->symbol = symbol; | |
| 6737 specpdl_ptr++; | |
| 6738 specpdl_depth_counter++; | |
| 6739 | |
| 6740 Fset (symbol, value); | |
| 853 | 6741 |
| 6742 check_specbind_stack_sanity (); | |
| 428 | 6743 } |
| 6744 | |
| 771 | 6745 /* Record an unwind-protect -- FUNCTION will be called with ARG no matter |
| 6746 whether a normal or non-local exit occurs. (You need to call unbind_to_1() | |
| 6747 before your function returns normally, passing in the integer returned | |
| 6748 by this function.) Note: As long as the unwind-protect exists, ARG is | |
| 6749 automatically GCPRO'd. The return value from FUNCTION is completely | |
| 6750 ignored. #### We should eliminate it entirely. */ | |
| 6751 | |
| 6752 int | |
| 428 | 6753 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg), |
| 6754 Lisp_Object arg) | |
| 6755 { | |
| 6756 SPECPDL_RESERVE (1); | |
| 6757 specpdl_ptr->func = function; | |
| 6758 specpdl_ptr->symbol = Qnil; | |
| 6759 specpdl_ptr->old_value = arg; | |
| 6760 specpdl_ptr++; | |
| 6761 specpdl_depth_counter++; | |
| 853 | 6762 check_specbind_stack_sanity (); |
| 771 | 6763 return specpdl_depth_counter - 1; |
| 6764 } | |
| 6765 | |
| 6766 static Lisp_Object | |
| 802 | 6767 restore_lisp_object (Lisp_Object cons) |
| 6768 { | |
| 5013 | 6769 Lisp_Object laddr = XCAR (cons); |
| 6770 Lisp_Object *addr = (Lisp_Object *) GET_VOID_FROM_LISP (laddr); | |
| 802 | 6771 *addr = XCDR (cons); |
| 853 | 6772 free_cons (cons); |
| 802 | 6773 return Qnil; |
| 6774 } | |
| 6775 | |
| 6776 /* Establish an unwind-protect which will restore the Lisp_Object pointed to | |
| 6777 by ADDR with the value VAL. */ | |
| 814 | 6778 static int |
| 802 | 6779 record_unwind_protect_restoring_lisp_object (Lisp_Object *addr, |
| 6780 Lisp_Object val) | |
| 6781 { | |
| 5013 | 6782 /* We use a cons rather than a malloc()ed structure because we want the |
| 6783 Lisp object to have garbage-collection protection */ | |
| 6784 Lisp_Object laddr = STORE_VOID_IN_LISP (addr); | |
| 802 | 6785 return record_unwind_protect (restore_lisp_object, |
| 5013 | 6786 noseeum_cons (laddr, val)); |
| 802 | 6787 } |
| 6788 | |
| 6789 /* Similar to specbind() but for any C variable whose value is a | |
| 6790 Lisp_Object. Sets up an unwind-protect to restore the variable | |
| 6791 pointed to by ADDR to its existing value, and then changes its | |
| 6792 value to NEWVAL. Returns the previous value of specpdl_depth(); | |
| 6793 pass this to unbind_to() after you are done. */ | |
| 6794 int | |
| 6795 internal_bind_lisp_object (Lisp_Object *addr, Lisp_Object newval) | |
| 6796 { | |
| 6797 int count = specpdl_depth (); | |
| 6798 record_unwind_protect_restoring_lisp_object (addr, *addr); | |
| 6799 *addr = newval; | |
| 6800 return count; | |
| 6801 } | |
| 6802 | |
| 5013 | 6803 struct restore_int |
| 6804 { | |
| 6805 int *addr; | |
| 802 | 6806 int val; |
| 5013 | 6807 }; |
| 6808 | |
| 6809 static Lisp_Object | |
| 6810 restore_int (Lisp_Object obj) | |
| 6811 { | |
| 6812 struct restore_int *ri = (struct restore_int *) GET_VOID_FROM_LISP (obj); | |
| 6813 *(ri->addr) = ri->val; | |
| 6814 xfree (ri); | |
| 802 | 6815 return Qnil; |
| 6816 } | |
| 6817 | |
| 6818 /* Establish an unwind-protect which will restore the int pointed to | |
| 6819 by ADDR with the value VAL. This function works correctly with | |
| 6820 all ints, even those that don't fit into a Lisp integer. */ | |
| 1333 | 6821 int |
| 802 | 6822 record_unwind_protect_restoring_int (int *addr, int val) |
| 6823 { | |
| 5013 | 6824 struct restore_int *ri = xnew (struct restore_int); |
| 6825 ri->addr = addr; | |
| 6826 ri->val = val; | |
| 6827 return record_unwind_protect (restore_int, STORE_VOID_IN_LISP (ri)); | |
| 802 | 6828 } |
| 6829 | |
| 6830 /* Similar to specbind() but for any C variable whose value is an int. | |
| 6831 Sets up an unwind-protect to restore the variable pointed to by | |
| 6832 ADDR to its existing value, and then changes its value to NEWVAL. | |
| 6833 Returns the previous value of specpdl_depth(); pass this to | |
| 6834 unbind_to() after you are done. This function works correctly with | |
| 6835 all ints, even those that don't fit into a Lisp integer. */ | |
| 6836 int | |
| 6837 internal_bind_int (int *addr, int newval) | |
| 6838 { | |
| 6839 int count = specpdl_depth (); | |
| 6840 record_unwind_protect_restoring_int (addr, *addr); | |
| 6841 *addr = newval; | |
| 6842 return count; | |
| 6843 } | |
| 6844 | |
| 6845 static Lisp_Object | |
| 771 | 6846 free_pointer (Lisp_Object opaque) |
| 6847 { | |
| 5013 | 6848 void *ptr = GET_VOID_FROM_LISP (opaque); |
| 6849 xfree (ptr); | |
| 771 | 6850 return Qnil; |
| 6851 } | |
| 6852 | |
| 6853 /* Establish an unwind-protect which will free the specified block. | |
| 6854 */ | |
| 6855 int | |
| 6856 record_unwind_protect_freeing (void *ptr) | |
| 6857 { | |
| 5013 | 6858 return record_unwind_protect (free_pointer, STORE_VOID_IN_LISP (ptr)); |
| 771 | 6859 } |
| 6860 | |
| 6861 static Lisp_Object | |
| 6862 free_dynarr (Lisp_Object opaque) | |
| 6863 { | |
| 5013 | 6864 Dynarr_free (GET_VOID_FROM_LISP (opaque)); |
| 771 | 6865 return Qnil; |
| 6866 } | |
| 6867 | |
| 6868 int | |
| 6869 record_unwind_protect_freeing_dynarr (void *ptr) | |
| 6870 { | |
| 5013 | 6871 return record_unwind_protect (free_dynarr, STORE_VOID_IN_LISP (ptr)); |
| 771 | 6872 } |
| 428 | 6873 |
| 6874 /* Unwind the stack till specpdl_depth() == COUNT. | |
| 6875 VALUE is not used, except that, purely as a convenience to the | |
| 771 | 6876 caller, it is protected from garbage-protection and returned. */ |
| 428 | 6877 Lisp_Object |
| 771 | 6878 unbind_to_1 (int count, Lisp_Object value) |
| 428 | 6879 { |
| 6880 UNBIND_TO_GCPRO (count, value); | |
| 853 | 6881 check_specbind_stack_sanity (); |
| 428 | 6882 return value; |
| 6883 } | |
| 6884 | |
| 6885 /* Don't call this directly. | |
| 6886 Only for use by UNBIND_TO* macros in backtrace.h */ | |
| 6887 void | |
| 6888 unbind_to_hairy (int count) | |
| 6889 { | |
| 442 | 6890 ++specpdl_ptr; |
| 6891 ++specpdl_depth_counter; | |
| 6892 | |
| 428 | 6893 while (specpdl_depth_counter != count) |
| 6894 { | |
| 1313 | 6895 Lisp_Object oquit = Qunbound; |
| 6896 | |
| 6897 /* Do this check BEFORE decrementing the values below, because once | |
| 6898 they're decremented, GC protection is lost on | |
| 6899 specpdl_ptr->old_value. */ | |
| 1322 | 6900 if (specpdl_ptr[-1].func == Fprogn) |
| 1313 | 6901 { |
| 6902 /* Allow QUIT within unwind-protect routines, but defer any | |
| 6903 existing QUIT until afterwards. Only do this, however, for | |
| 6904 unwind-protects established by Lisp code, not by C code | |
| 6905 (e.g. free_opaque_ptr() or something), because the act of | |
| 6906 checking for QUIT can cause all sorts of weird things to | |
| 6907 happen, since it churns the event loop -- redisplay, running | |
| 6908 Lisp, etc. Code should not have to worry about this just | |
| 6909 because of establishing an unwind-protect. */ | |
| 6910 check_quit (); /* make Vquit_flag accurate */ | |
| 6911 oquit = Vquit_flag; | |
| 6912 Vquit_flag = Qnil; | |
| 6913 } | |
| 6914 | |
| 428 | 6915 --specpdl_ptr; |
| 6916 --specpdl_depth_counter; | |
| 6917 | |
| 1313 | 6918 /* #### At this point, there is no GC protection on old_value. This |
| 6919 could be a real problem, depending on what unwind-protect function | |
| 6920 is called. It looks like it just so happens that the ones | |
| 6921 actually called don't have a problem with this, e.g. Fprogn. But | |
| 6922 we should look into fixing this. (Many unwind-protect functions | |
| 6923 free values. Is it a problem if freed values are | |
| 6924 GC-protected?) */ | |
| 428 | 6925 if (specpdl_ptr->func != 0) |
| 1313 | 6926 { |
| 6927 /* An unwind-protect */ | |
| 6928 (*specpdl_ptr->func) (specpdl_ptr->old_value); | |
| 6929 } | |
| 6930 | |
| 428 | 6931 else |
| 6932 { | |
| 6933 /* We checked symbol for validity when we specbound it, | |
| 6934 so only need to call Fset if symbol has magic value. */ | |
| 440 | 6935 Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol); |
| 428 | 6936 if (!SYMBOL_VALUE_MAGIC_P (sym->value)) |
| 6937 sym->value = specpdl_ptr->old_value; | |
| 6938 else | |
| 6939 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value); | |
| 6940 } | |
| 6941 | |
| 6942 #if 0 /* martin */ | |
| 6943 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE | |
| 6944 /* There should never be anything here for us to remove. | |
| 6945 If so, it indicates a logic error in Emacs. Catches | |
| 6946 should get removed when a throw or signal occurs, or | |
| 6947 when a catch or condition-case exits normally. But | |
| 6948 it's too dangerous to just remove this code. --ben */ | |
| 6949 | |
| 6950 /* Furthermore, this code is not in FSFmacs!!! | |
| 6951 Braino on mly's part? */ | |
| 6952 /* If we're unwound past the pdlcount of a catch frame, | |
| 6953 that catch can't possibly still be valid. */ | |
| 6954 while (catchlist && catchlist->pdlcount > specpdl_depth_counter) | |
| 6955 { | |
| 6956 catchlist = catchlist->next; | |
| 6957 /* Don't mess with gcprolist, backtrace_list here */ | |
| 6958 } | |
| 6959 #endif | |
| 6960 #endif | |
| 1313 | 6961 |
| 6962 if (!UNBOUNDP (oquit)) | |
| 6963 Vquit_flag = oquit; | |
| 428 | 6964 } |
| 853 | 6965 check_specbind_stack_sanity (); |
| 428 | 6966 } |
| 6967 | |
| 6968 | |
| 6969 | |
| 6970 /* Get the value of symbol's global binding, even if that binding is | |
| 6971 not now dynamically visible. May return Qunbound or magic values. */ | |
| 6972 | |
| 6973 Lisp_Object | |
| 6974 top_level_value (Lisp_Object symbol) | |
| 6975 { | |
| 6976 REGISTER struct specbinding *ptr = specpdl; | |
| 6977 | |
| 6978 CHECK_SYMBOL (symbol); | |
| 6979 for (; ptr != specpdl_ptr; ptr++) | |
| 6980 { | |
| 6981 if (EQ (ptr->symbol, symbol)) | |
| 6982 return ptr->old_value; | |
| 6983 } | |
| 6984 return XSYMBOL (symbol)->value; | |
| 6985 } | |
| 6986 | |
| 6987 #if 0 | |
| 6988 | |
| 6989 Lisp_Object | |
| 6990 top_level_set (Lisp_Object symbol, Lisp_Object newval) | |
| 6991 { | |
| 6992 REGISTER struct specbinding *ptr = specpdl; | |
| 6993 | |
| 6994 CHECK_SYMBOL (symbol); | |
| 6995 for (; ptr != specpdl_ptr; ptr++) | |
| 6996 { | |
| 6997 if (EQ (ptr->symbol, symbol)) | |
| 6998 { | |
| 6999 ptr->old_value = newval; | |
| 7000 return newval; | |
| 7001 } | |
| 7002 } | |
| 7003 return Fset (symbol, newval); | |
| 7004 } | |
| 7005 | |
| 7006 #endif /* 0 */ | |
| 7007 | |
| 7008 | |
| 7009 /************************************************************************/ | |
| 7010 /* Backtraces */ | |
| 7011 /************************************************************************/ | |
| 7012 | |
| 7013 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /* | |
| 7014 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. | |
| 7015 The debugger is entered when that frame exits, if the flag is non-nil. | |
| 7016 */ | |
| 7017 (level, flag)) | |
| 7018 { | |
| 7019 REGISTER struct backtrace *backlist = backtrace_list; | |
| 7020 REGISTER int i; | |
| 7021 | |
| 7022 CHECK_INT (level); | |
| 7023 | |
| 7024 for (i = 0; backlist && i < XINT (level); i++) | |
| 7025 { | |
| 7026 backlist = backlist->next; | |
| 7027 } | |
| 7028 | |
| 7029 if (backlist) | |
| 7030 backlist->debug_on_exit = !NILP (flag); | |
| 7031 | |
| 7032 return flag; | |
| 7033 } | |
| 7034 | |
| 7035 static void | |
| 7036 backtrace_specials (int speccount, int speclimit, Lisp_Object stream) | |
| 7037 { | |
| 7038 int printing_bindings = 0; | |
| 7039 | |
| 7040 for (; speccount > speclimit; speccount--) | |
| 7041 { | |
| 7042 if (specpdl[speccount - 1].func == 0 | |
| 7043 || specpdl[speccount - 1].func == specbind_unwind_local | |
| 7044 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local) | |
| 7045 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7046 write_ascstring (stream, !printing_bindings ? " # bind (" : " "); |
| 428 | 7047 Fprin1 (specpdl[speccount - 1].symbol, stream); |
| 7048 printing_bindings = 1; | |
| 7049 } | |
| 7050 else | |
| 7051 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7052 if (printing_bindings) write_ascstring (stream, ")\n"); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7053 write_ascstring (stream, " # (unwind-protect ...)\n"); |
| 428 | 7054 printing_bindings = 0; |
| 7055 } | |
| 7056 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7057 if (printing_bindings) write_ascstring (stream, ")\n"); |
| 428 | 7058 } |
| 7059 | |
| 1292 | 7060 static Lisp_Object |
| 7061 backtrace_unevalled_args (Lisp_Object *args) | |
| 7062 { | |
| 7063 if (args) | |
| 7064 return *args; | |
| 7065 else | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7066 return list1 (build_ascstring ("[internal]")); |
| 1292 | 7067 } |
| 7068 | |
| 428 | 7069 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /* |
| 7070 Print a trace of Lisp function calls currently active. | |
| 438 | 7071 Optional arg STREAM specifies the output stream to send the backtrace to, |
| 444 | 7072 and defaults to the value of `standard-output'. |
| 7073 Optional second arg DETAILED non-nil means show places where currently | |
| 7074 active variable bindings, catches, condition-cases, and | |
| 7075 unwind-protects, as well as function calls, were made. | |
| 428 | 7076 */ |
| 7077 (stream, detailed)) | |
| 7078 { | |
| 7079 /* This function can GC */ | |
| 7080 struct backtrace *backlist = backtrace_list; | |
| 7081 struct catchtag *catches = catchlist; | |
| 7082 int speccount = specpdl_depth(); | |
| 7083 | |
| 7084 int old_nl = print_escape_newlines; | |
| 7085 int old_pr = print_readably; | |
| 7086 Lisp_Object old_level = Vprint_level; | |
| 7087 Lisp_Object oiq = Vinhibit_quit; | |
| 7088 struct gcpro gcpro1, gcpro2; | |
| 7089 | |
| 7090 /* We can't allow quits in here because that could cause the values | |
| 7091 of print_readably and print_escape_newlines to get screwed up. | |
| 7092 Normally we would use a record_unwind_protect but that would | |
| 7093 screw up the functioning of this function. */ | |
| 7094 Vinhibit_quit = Qt; | |
| 7095 | |
| 7096 entering_debugger = 0; | |
| 7097 | |
| 872 | 7098 if (!NILP (detailed)) |
| 7099 Vprint_level = make_int (50); | |
| 7100 else | |
| 7101 Vprint_level = make_int (3); | |
| 428 | 7102 print_readably = 0; |
| 7103 print_escape_newlines = 1; | |
| 7104 | |
| 7105 GCPRO2 (stream, old_level); | |
| 7106 | |
| 1261 | 7107 stream = canonicalize_printcharfun (stream); |
| 428 | 7108 |
| 7109 for (;;) | |
| 7110 { | |
| 7111 if (!NILP (detailed) && catches && catches->backlist == backlist) | |
| 7112 { | |
| 7113 int catchpdl = catches->pdlcount; | |
| 438 | 7114 if (speccount > catchpdl |
| 7115 && specpdl[catchpdl].func == condition_case_unwind) | |
| 428 | 7116 /* This is a condition-case catchpoint */ |
| 7117 catchpdl = catchpdl + 1; | |
| 7118 | |
| 7119 backtrace_specials (speccount, catchpdl, stream); | |
| 7120 | |
| 7121 speccount = catches->pdlcount; | |
| 7122 if (catchpdl == speccount) | |
| 7123 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7124 write_ascstring (stream, " # (catch "); |
| 428 | 7125 Fprin1 (catches->tag, stream); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7126 write_ascstring (stream, " ...)\n"); |
| 428 | 7127 } |
| 7128 else | |
| 7129 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7130 write_ascstring (stream, " # (condition-case ... . "); |
| 428 | 7131 Fprin1 (Fcdr (Fcar (catches->tag)), stream); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7132 write_ascstring (stream, ")\n"); |
| 428 | 7133 } |
| 7134 catches = catches->next; | |
| 7135 } | |
| 7136 else if (!backlist) | |
| 7137 break; | |
| 7138 else | |
| 7139 { | |
| 7140 if (!NILP (detailed) && backlist->pdlcount < speccount) | |
| 7141 { | |
| 7142 backtrace_specials (speccount, backlist->pdlcount, stream); | |
| 7143 speccount = backlist->pdlcount; | |
| 7144 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7145 write_ascstring (stream, backlist->debug_on_exit ? "* " : " "); |
| 428 | 7146 if (backlist->nargs == UNEVALLED) |
| 7147 { | |
| 1292 | 7148 Fprin1 (Fcons (*backlist->function, |
| 7149 backtrace_unevalled_args (backlist->args)), | |
| 7150 stream); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7151 write_ascstring (stream, "\n"); /* from FSFmacs 19.30 */ |
| 428 | 7152 } |
| 7153 else | |
| 7154 { | |
| 7155 Lisp_Object tem = *backlist->function; | |
| 7156 Fprin1 (tem, stream); /* This can QUIT */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7157 write_ascstring (stream, "("); |
| 428 | 7158 if (backlist->nargs == MANY) |
| 7159 { | |
| 7160 int i; | |
| 7161 Lisp_Object tail = Qnil; | |
| 7162 struct gcpro ngcpro1; | |
| 7163 | |
| 7164 NGCPRO1 (tail); | |
| 7165 for (tail = *backlist->args, i = 0; | |
| 7166 !NILP (tail); | |
| 7167 tail = Fcdr (tail), i++) | |
| 7168 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7169 if (i != 0) write_ascstring (stream, " "); |
| 428 | 7170 Fprin1 (Fcar (tail), stream); |
| 7171 } | |
| 7172 NUNGCPRO; | |
| 7173 } | |
| 7174 else | |
| 7175 { | |
| 7176 int i; | |
| 7177 for (i = 0; i < backlist->nargs; i++) | |
| 7178 { | |
| 826 | 7179 if (!i && EQ (tem, Qbyte_code)) |
| 7180 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7181 write_ascstring (stream, "\"...\""); |
| 826 | 7182 continue; |
| 7183 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7184 if (i != 0) write_ascstring (stream, " "); |
| 428 | 7185 Fprin1 (backlist->args[i], stream); |
| 7186 } | |
| 7187 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7188 write_ascstring (stream, ")\n"); |
| 428 | 7189 } |
| 7190 backlist = backlist->next; | |
| 7191 } | |
| 7192 } | |
| 7193 Vprint_level = old_level; | |
| 7194 print_readably = old_pr; | |
| 7195 print_escape_newlines = old_nl; | |
| 7196 UNGCPRO; | |
| 7197 Vinhibit_quit = oiq; | |
| 7198 return Qnil; | |
| 7199 } | |
| 7200 | |
| 7201 | |
| 444 | 7202 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /* |
| 7203 Return the function and arguments NFRAMES up from current execution point. | |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
7204 If that frame has not evaluated the arguments yet (or involves a special |
|
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
7205 operator), the value is (nil FUNCTION ARG-FORMS...). |
| 428 | 7206 If that frame has evaluated its arguments and called its function already, |
| 7207 the value is (t FUNCTION ARG-VALUES...). | |
| 7208 A &rest arg is represented as the tail of the list ARG-VALUES. | |
| 7209 FUNCTION is whatever was supplied as car of evaluated list, | |
| 7210 or a lambda expression for macro calls. | |
| 444 | 7211 If NFRAMES is more than the number of frames, the value is nil. |
| 428 | 7212 */ |
| 7213 (nframes)) | |
| 7214 { | |
| 7215 REGISTER struct backtrace *backlist = backtrace_list; | |
| 7216 REGISTER int i; | |
| 7217 Lisp_Object tem; | |
| 7218 | |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
7219 check_integer_range (nframes, Qzero, make_integer (EMACS_INT_MAX)); |
| 428 | 7220 |
| 7221 /* Find the frame requested. */ | |
| 7222 for (i = XINT (nframes); backlist && (i-- > 0);) | |
| 7223 backlist = backlist->next; | |
| 7224 | |
| 7225 if (!backlist) | |
| 7226 return Qnil; | |
| 7227 if (backlist->nargs == UNEVALLED) | |
| 1292 | 7228 return Fcons (Qnil, Fcons (*backlist->function, |
| 7229 backtrace_unevalled_args (backlist->args))); | |
| 428 | 7230 else |
| 7231 { | |
| 7232 if (backlist->nargs == MANY) | |
| 7233 tem = *backlist->args; | |
| 7234 else | |
| 7235 tem = Flist (backlist->nargs, backlist->args); | |
| 7236 | |
| 7237 return Fcons (Qt, Fcons (*backlist->function, tem)); | |
| 7238 } | |
| 7239 } | |
| 7240 | |
| 7241 | |
| 7242 /************************************************************************/ | |
| 7243 /* Warnings */ | |
| 7244 /************************************************************************/ | |
| 7245 | |
| 1123 | 7246 static int |
| 7247 warning_will_be_discarded (Lisp_Object level) | |
| 7248 { | |
| 7249 /* Don't even generate debug warnings if they're going to be discarded, | |
| 7250 to avoid excessive consing. */ | |
| 7251 return (EQ (level, Qdebug) && !NILP (Vlog_warning_minimum_level) && | |
| 7252 !EQ (Vlog_warning_minimum_level, Qdebug)); | |
| 7253 } | |
| 7254 | |
| 428 | 7255 void |
| 1204 | 7256 warn_when_safe_lispobj (Lisp_Object class_, Lisp_Object level, |
| 428 | 7257 Lisp_Object obj) |
| 7258 { | |
| 1123 | 7259 if (warning_will_be_discarded (level)) |
| 793 | 7260 return; |
| 1123 | 7261 |
| 1204 | 7262 obj = list1 (list3 (class_, level, obj)); |
| 428 | 7263 if (NILP (Vpending_warnings)) |
| 7264 Vpending_warnings = Vpending_warnings_tail = obj; | |
| 7265 else | |
| 7266 { | |
| 7267 Fsetcdr (Vpending_warnings_tail, obj); | |
| 7268 Vpending_warnings_tail = obj; | |
| 7269 } | |
| 7270 } | |
| 7271 | |
| 7272 /* #### This should probably accept Lisp objects; but then we have | |
| 7273 to make sure that Feval() isn't called, since it might not be safe. | |
| 7274 | |
| 7275 An alternative approach is to just pass some non-string type of | |
| 7276 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will | |
| 7277 automatically be called when it is safe to do so. */ | |
| 7278 | |
| 7279 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7280 warn_when_safe (Lisp_Object class_, Lisp_Object level, const Ascbyte *fmt, ...) |
| 428 | 7281 { |
| 7282 Lisp_Object obj; | |
| 7283 va_list args; | |
| 7284 | |
| 1123 | 7285 if (warning_will_be_discarded (level)) |
| 793 | 7286 return; |
| 1123 | 7287 |
| 428 | 7288 va_start (args, fmt); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7289 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 7290 va_end (args); |
| 7291 | |
| 1204 | 7292 warn_when_safe_lispobj (class_, level, obj); |
| 428 | 7293 } |
| 7294 | |
| 7295 | |
| 7296 | |
| 7297 | |
| 7298 /************************************************************************/ | |
| 7299 /* Initialization */ | |
| 7300 /************************************************************************/ | |
| 7301 | |
| 7302 void | |
| 7303 syms_of_eval (void) | |
| 7304 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
7305 INIT_LISP_OBJECT (subr); |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7306 INIT_LISP_OBJECT (multiple_value); |
| 442 | 7307 |
| 563 | 7308 DEFSYMBOL (Qinhibit_quit); |
| 7309 DEFSYMBOL (Qautoload); | |
| 7310 DEFSYMBOL (Qdebug_on_error); | |
| 7311 DEFSYMBOL (Qstack_trace_on_error); | |
| 7312 DEFSYMBOL (Qdebug_on_signal); | |
| 7313 DEFSYMBOL (Qstack_trace_on_signal); | |
| 7314 DEFSYMBOL (Qdebugger); | |
| 7315 DEFSYMBOL (Qmacro); | |
| 428 | 7316 defsymbol (&Qand_rest, "&rest"); |
| 7317 defsymbol (&Qand_optional, "&optional"); | |
| 7318 /* Note that the process code also uses Qexit */ | |
| 563 | 7319 DEFSYMBOL (Qexit); |
| 7320 DEFSYMBOL (Qsetq); | |
| 7321 DEFSYMBOL (Qinteractive); | |
| 7322 DEFSYMBOL (Qcommandp); | |
| 7323 DEFSYMBOL (Qdefun); | |
| 7324 DEFSYMBOL (Qprogn); | |
| 7325 DEFSYMBOL (Qvalues); | |
| 7326 DEFSYMBOL (Qdisplay_warning); | |
| 7327 DEFSYMBOL (Qrun_hooks); | |
| 887 | 7328 DEFSYMBOL (Qfinalize_list); |
| 563 | 7329 DEFSYMBOL (Qif); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7330 DEFSYMBOL (Qthrow); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7331 DEFSYMBOL (Qobsolete_throw); |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
7332 DEFSYMBOL (Qmultiple_value_list_internal); |
| 428 | 7333 |
| 7334 DEFSUBR (For); | |
| 7335 DEFSUBR (Fand); | |
| 7336 DEFSUBR (Fif); | |
| 7337 DEFSUBR_MACRO (Fwhen); | |
| 7338 DEFSUBR_MACRO (Funless); | |
| 7339 DEFSUBR (Fcond); | |
| 7340 DEFSUBR (Fprogn); | |
| 7341 DEFSUBR (Fprog1); | |
| 7342 DEFSUBR (Fprog2); | |
| 7343 DEFSUBR (Fsetq); | |
| 7344 DEFSUBR (Fquote); | |
|
4744
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
7345 DEFSUBR (Fquote_maybe); |
| 428 | 7346 DEFSUBR (Ffunction); |
| 7347 DEFSUBR (Fdefun); | |
| 7348 DEFSUBR (Fdefmacro); | |
| 7349 DEFSUBR (Fdefvar); | |
| 7350 DEFSUBR (Fdefconst); | |
| 7351 DEFSUBR (Flet); | |
| 7352 DEFSUBR (FletX); | |
| 7353 DEFSUBR (Fwhile); | |
| 7354 DEFSUBR (Fmacroexpand_internal); | |
| 7355 DEFSUBR (Fcatch); | |
| 7356 DEFSUBR (Fthrow); | |
| 7357 DEFSUBR (Funwind_protect); | |
| 7358 DEFSUBR (Fcondition_case); | |
| 7359 DEFSUBR (Fcall_with_condition_handler); | |
| 7360 DEFSUBR (Fsignal); | |
| 7361 DEFSUBR (Finteractive_p); | |
| 7362 DEFSUBR (Fcommandp); | |
| 7363 DEFSUBR (Fcommand_execute); | |
| 7364 DEFSUBR (Fautoload); | |
| 7365 DEFSUBR (Feval); | |
| 7366 DEFSUBR (Fapply); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7367 DEFSUBR (Fmultiple_value_call); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7368 DEFSUBR (Fmultiple_value_list_internal); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7369 DEFSUBR (Fmultiple_value_prog1); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7370 DEFSUBR (Fvalues); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7371 DEFSUBR (Fvalues_list); |
| 428 | 7372 DEFSUBR (Ffuncall); |
| 7373 DEFSUBR (Ffunctionp); | |
| 7374 DEFSUBR (Ffunction_min_args); | |
| 7375 DEFSUBR (Ffunction_max_args); | |
| 7376 DEFSUBR (Frun_hooks); | |
| 7377 DEFSUBR (Frun_hook_with_args); | |
| 7378 DEFSUBR (Frun_hook_with_args_until_success); | |
| 7379 DEFSUBR (Frun_hook_with_args_until_failure); | |
| 7380 DEFSUBR (Fbacktrace_debug); | |
| 7381 DEFSUBR (Fbacktrace); | |
| 7382 DEFSUBR (Fbacktrace_frame); | |
| 7383 } | |
| 7384 | |
| 7385 void | |
| 814 | 7386 init_eval_semi_early (void) |
| 428 | 7387 { |
| 7388 specpdl_ptr = specpdl; | |
| 7389 specpdl_depth_counter = 0; | |
| 7390 catchlist = 0; | |
| 7391 Vcondition_handlers = Qnil; | |
| 7392 backtrace_list = 0; | |
| 7393 Vquit_flag = Qnil; | |
| 7394 debug_on_next_call = 0; | |
| 7395 lisp_eval_depth = 0; | |
| 7396 entering_debugger = 0; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7397 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7398 first_desired_multiple_value = 0; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7399 multiple_value_current_limit = 1; |
| 428 | 7400 } |
| 7401 | |
| 7402 void | |
| 7403 reinit_vars_of_eval (void) | |
| 7404 { | |
| 7405 preparing_for_armageddon = 0; | |
| 7406 in_warnings = 0; | |
| 7407 specpdl_size = 50; | |
| 7408 specpdl = xnew_array (struct specbinding, specpdl_size); | |
| 7409 /* XEmacs change: increase these values. */ | |
| 7410 max_specpdl_size = 3000; | |
| 442 | 7411 max_lisp_eval_depth = 1000; |
| 7412 #ifdef DEFEND_AGAINST_THROW_RECURSION | |
| 428 | 7413 throw_level = 0; |
| 7414 #endif | |
| 2367 | 7415 init_eval_semi_early (); |
| 428 | 7416 } |
| 7417 | |
| 7418 void | |
| 7419 vars_of_eval (void) | |
| 7420 { | |
| 7421 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /* | |
| 7422 Limit on number of Lisp variable bindings & unwind-protects before error. | |
| 7423 */ ); | |
| 7424 | |
| 7425 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /* | |
| 7426 Limit on depth in `eval', `apply' and `funcall' before error. | |
| 7427 This limit is to catch infinite recursions for you before they cause | |
| 7428 actual stack overflow in C, which would be fatal for Emacs. | |
| 7429 You can safely make it considerably larger than its default value, | |
| 7430 if that proves inconveniently small. | |
| 7431 */ ); | |
| 7432 | |
| 7433 DEFVAR_LISP ("quit-flag", &Vquit_flag /* | |
| 853 | 7434 t causes running Lisp code to abort, unless `inhibit-quit' is non-nil. |
| 7435 `critical' causes running Lisp code to abort regardless of `inhibit-quit'. | |
| 7436 Normally, you do not need to set this value yourself. It is set to | |
| 7437 t each time a Control-G is detected, and to `critical' each time a | |
| 7438 Shift-Control-G is detected. The XEmacs core C code is littered with | |
| 7439 calls to the QUIT; macro, which check the values of `quit-flag' and | |
| 2500 | 7440 `inhibit-quit' and ABORT (or more accurately, call (signal 'quit)) if |
| 853 | 7441 it's correct to do so. |
| 428 | 7442 */ ); |
| 7443 Vquit_flag = Qnil; | |
| 7444 | |
| 7445 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /* | |
| 7446 Non-nil inhibits C-g quitting from happening immediately. | |
| 7447 Note that `quit-flag' will still be set by typing C-g, | |
| 7448 so a quit will be signalled as soon as `inhibit-quit' is nil. | |
| 7449 To prevent this happening, set `quit-flag' to nil | |
| 853 | 7450 before making `inhibit-quit' nil. |
| 7451 | |
| 7452 The value of `inhibit-quit' is ignored if a critical quit is | |
| 7453 requested by typing control-shift-G in a window-system frame; | |
| 7454 this is explained in more detail in `quit-flag'. | |
| 428 | 7455 */ ); |
| 7456 Vinhibit_quit = Qnil; | |
| 7457 | |
| 7458 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /* | |
| 7459 *Non-nil means automatically display a backtrace buffer | |
| 7460 after any error that is not handled by a `condition-case'. | |
| 7461 If the value is a list, an error only means to display a backtrace | |
| 7462 if one of its condition symbols appears in the list. | |
| 7463 See also variable `stack-trace-on-signal'. | |
| 7464 */ ); | |
| 7465 Vstack_trace_on_error = Qnil; | |
| 7466 | |
| 7467 DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /* | |
| 7468 *Non-nil means automatically display a backtrace buffer | |
| 7469 after any error that is signalled, whether or not it is handled by | |
| 7470 a `condition-case'. | |
| 7471 If the value is a list, an error only means to display a backtrace | |
| 7472 if one of its condition symbols appears in the list. | |
| 7473 See also variable `stack-trace-on-error'. | |
| 7474 */ ); | |
| 7475 Vstack_trace_on_signal = Qnil; | |
| 7476 | |
| 7477 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /* | |
| 7478 *List of errors for which the debugger should not be called. | |
| 7479 Each element may be a condition-name or a regexp that matches error messages. | |
| 7480 If any element applies to a given error, that error skips the debugger | |
| 7481 and just returns to top level. | |
| 7482 This overrides the variable `debug-on-error'. | |
| 7483 It does not apply to errors handled by `condition-case'. | |
| 7484 */ ); | |
| 7485 Vdebug_ignored_errors = Qnil; | |
| 7486 | |
| 7487 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /* | |
| 7488 *Non-nil means enter debugger if an unhandled error is signalled. | |
| 7489 The debugger will not be entered if the error is handled by | |
| 7490 a `condition-case'. | |
| 7491 If the value is a list, an error only means to enter the debugger | |
| 7492 if one of its condition symbols appears in the list. | |
| 7493 This variable is overridden by `debug-ignored-errors'. | |
| 7494 See also variables `debug-on-quit' and `debug-on-signal'. | |
| 1123 | 7495 |
|
4657
f8d7d8202635
imported patch accept-process-output-docstring
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4642
diff
changeset
|
7496 Process filters are considered to be outside of condition-case forms |
|
f8d7d8202635
imported patch accept-process-output-docstring
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4642
diff
changeset
|
7497 (unless contained in the process filter itself). To prevent the |
|
f8d7d8202635
imported patch accept-process-output-docstring
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4642
diff
changeset
|
7498 debugger from being called from a process filter, use a list value, or |
|
f8d7d8202635
imported patch accept-process-output-docstring
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4642
diff
changeset
|
7499 put the expected error\(s) in `debug-ignored-errors'. |
|
f8d7d8202635
imported patch accept-process-output-docstring
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4642
diff
changeset
|
7500 |
| 1123 | 7501 If this variable is set while XEmacs is running noninteractively (using |
| 7502 `-batch'), and XEmacs was configured with `--debug' (#define XEMACS_DEBUG | |
| 7503 in the C code), instead of trying to invoke the Lisp debugger (which | |
| 7504 obviously won't work), XEmacs will break out to a C debugger using | |
| 7505 \(force-debugging-signal t). This is useful because debugging | |
| 7506 noninteractive runs of XEmacs is often very difficult, since they typically | |
| 7507 happen as part of sometimes large and complex make suites (e.g. rebuilding | |
| 2500 | 7508 the XEmacs packages). NOTE: This runs ABORT()!!! (As well as and after |
| 1123 | 7509 executing INT 3 under MS Windows, which should invoke a debugger if it's |
| 7510 active.) This is guaranteed to kill XEmacs! (But in this situation, XEmacs | |
| 7511 is about to die anyway, and if no debugger is present, this will usefully | |
| 7512 dump core.) The most useful way to set this flag when debugging | |
| 7513 noninteractive runs, especially in makefiles, is using the environment | |
| 7514 variable XEMACSDEBUG, like this: | |
| 771 | 7515 |
| 7516 \(using csh) setenv XEMACSDEBUG '(setq debug-on-error t)' | |
| 7517 \(using bash) export XEMACSDEBUG='(setq debug-on-error t)' | |
| 428 | 7518 */ ); |
| 7519 Vdebug_on_error = Qnil; | |
| 7520 | |
| 7521 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /* | |
| 7522 *Non-nil means enter debugger if an error is signalled. | |
| 7523 The debugger will be entered whether or not the error is handled by | |
| 7524 a `condition-case'. | |
| 7525 If the value is a list, an error only means to enter the debugger | |
| 7526 if one of its condition symbols appears in the list. | |
| 7527 See also variable `debug-on-quit'. | |
| 1123 | 7528 |
| 7529 This will attempt to enter a C debugger when XEmacs is run noninteractively | |
| 7530 and under the same conditions as described in `debug-on-error'. | |
| 428 | 7531 */ ); |
| 7532 Vdebug_on_signal = Qnil; | |
| 7533 | |
| 7534 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /* | |
| 7535 *Non-nil means enter debugger if quit is signalled (C-G, for example). | |
| 7536 Does not apply if quit is handled by a `condition-case'. Entering the | |
| 7537 debugger can also be achieved at any time (for X11 console) by typing | |
| 7538 control-shift-G to signal a critical quit. | |
| 7539 */ ); | |
| 7540 debug_on_quit = 0; | |
| 7541 | |
| 7542 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /* | |
| 7543 Non-nil means enter debugger before next `eval', `apply' or `funcall'. | |
| 7544 */ ); | |
| 7545 | |
| 1292 | 7546 DEFVAR_BOOL ("backtrace-with-interal-sections", |
| 7547 &backtrace_with_internal_sections /* | |
| 7548 Non-nil means backtraces will contain additional information indicating | |
| 7549 when particular sections of the C code have been entered, e.g. redisplay(), | |
| 7550 byte-char conversion, internal-external conversion, etc. This can be | |
| 7551 particularly useful when XEmacs crashes, in helping to pinpoint the problem. | |
| 7552 */ ); | |
| 7553 #ifdef ERROR_CHECK_STRUCTURES | |
| 7554 backtrace_with_internal_sections = 1; | |
| 7555 #else | |
| 7556 backtrace_with_internal_sections = 0; | |
| 7557 #endif | |
| 7558 | |
| 428 | 7559 DEFVAR_LISP ("debugger", &Vdebugger /* |
| 7560 Function to call to invoke debugger. | |
| 7561 If due to frame exit, args are `exit' and the value being returned; | |
| 7562 this function's value will be returned instead of that. | |
| 7563 If due to error, args are `error' and a list of the args to `signal'. | |
| 7564 If due to `apply' or `funcall' entry, one arg, `lambda'. | |
| 7565 If due to `eval' entry, one arg, t. | |
| 7566 */ ); | |
| 7567 Vdebugger = Qnil; | |
| 7568 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7569 DEFVAR_CONST_INT ("multiple-values-limit", &Vmultiple_values_limit /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7570 The exclusive upper bound on the number of multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7571 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7572 This applies to `values', `values-list', `multiple-value-bind' and related |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
7573 macros and special operators. |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7574 */); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7575 Vmultiple_values_limit = EMACS_INT_MAX > INT_MAX ? INT_MAX : EMACS_INT_MAX; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7576 |
| 853 | 7577 staticpro (&Vcatch_everything_tag); |
| 7578 Vcatch_everything_tag = make_opaque (OPAQUE_CLEAR, 0); | |
| 7579 | |
| 428 | 7580 staticpro (&Vpending_warnings); |
| 7581 Vpending_warnings = Qnil; | |
| 1204 | 7582 dump_add_root_lisp_object (&Vpending_warnings_tail); |
| 428 | 7583 Vpending_warnings_tail = Qnil; |
| 7584 | |
| 793 | 7585 DEFVAR_LISP ("log-warning-minimum-level", &Vlog_warning_minimum_level); |
| 7586 Vlog_warning_minimum_level = Qinfo; | |
| 7587 | |
| 428 | 7588 staticpro (&Vautoload_queue); |
| 7589 Vautoload_queue = Qnil; | |
| 7590 | |
| 7591 staticpro (&Vcondition_handlers); | |
| 7592 | |
| 853 | 7593 staticpro (&Vdeletable_permanent_display_objects); |
| 7594 Vdeletable_permanent_display_objects = Qnil; | |
| 7595 | |
| 7596 staticpro (&Vmodifiable_buffers); | |
| 7597 Vmodifiable_buffers = Qnil; | |
| 7598 | |
| 7599 inhibit_flags = 0; | |
| 7600 } |