Mercurial > hg > xemacs-beta
diff src/eval.c @ 4677:8f1ee2d15784
Support full Common Lisp multiple values in C.
lisp/ChangeLog
2009-08-11 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el :
Update this file to support full C-level multiple values. This
involves:
-- Four new bytecodes, and special compiler functions to compile
multiple-value-call, multiple-value-list-internal, values,
values-list, and, since it now needs to pass back multiple values
and is a special form, throw.
-- There's a new compiler variable, byte-compile-checks-on-load,
which is a list of forms that are evaluated at the very start of a
file, with an error thrown if any of them give nil.
-- The header is now inserted *after* compilation, giving a chance
for the compilation process to influence what those checks
are. There is still a check done before compilation for non-ASCII
characters, to try to turn off dynamic docstrings if appopriate,
in `byte-compile-maybe-reset-coding'.
Space is reserved for checks; comments describing the version of
the byte compiler generating the file are inserted if space
remains for them.
* bytecomp.el (byte-compile-version):
Update this, we're a newer version of the byte compiler.
* byte-optimize.el (byte-optimize-funcall):
Correct a comment.
* bytecomp.el (byte-compile-lapcode):
Discard the arg with byte-multiple-value-call.
* bytecomp.el (byte-compile-checks-and-comments-space):
New variable, describe how many octets to reserve for checks at
the start of byte-compiled files.
* cl-compat.el:
Remove the fake multiple-value implementation. Have the functions
that use it use the real multiple-value implementation instead.
* cl-macs.el (cl-block-wrapper, cl-block-throw):
Revise the byte-compile properties of these symbols to work now
we've made throw into a special form; keep the byte-compile
properties as anonymous lambdas, since we don't have docstrings
for them.
* cl-macs.el (multiple-value-bind, multiple-value-setq)
(multiple-value-list, nth-value):
Update these functions to work with the C support for multiple
values.
* cl-macs.el (values):
Modify the setf handler for this to call
#'multiple-value-list-internal appropriately.
* cl-macs.el (cl-setf-do-store):
If the store form is a cons, treat it specially as wrapping the
store value.
* cl.el (cl-block-wrapper):
Make this an alias of #'and, not #'identity, since it needs to
pass back multiple values.
* cl.el (multiple-value-apply):
We no longer support this, mark it obsolete.
* lisp-mode.el (eval-interactive-verbose):
Remove a useless space in the docstring.
* lisp-mode.el (eval-interactive):
Update this function and its docstring. It now passes back a list,
basically wrapping any eval calls with multiple-value-list. This
allows multiple values to be printed by default in *scratch*.
* lisp-mode.el (prin1-list-as-multiple-values):
New function, printing a list as multiple values in the manner of
Bruno Haible's clisp, separating each entry with " ;\n".
* lisp-mode.el (eval-last-sexp):
Call #'prin1-list-as-multiple-values on the return value of
#'eval-interactive.
* lisp-mode.el (eval-defun):
Call #'prin1-list-as-multiple-values on the return value of
#'eval-interactive.
* mouse.el (mouse-eval-sexp):
Deal with lists corresponding to multiple values from
#'eval-interactive. Call #'cl-prettyprint, which is always
available, instead of sometimes calling #'pprint and sometimes
falling back to prin1.
* obsolete.el (obsolete-throw):
New function, called from eval.c when #'funcall encounters an
attempt to call #'throw (now a special form) as a function. Only
needed for compatibility with 21.4 byte-code.
man/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea@parhasard.net>
* cl.texi (Organization):
Remove references to the obsolete multiple-value emulating code.
src/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea@parhasard.net>
* bytecode.c (enum Opcode /* Byte codes */):
Add four new bytecodes, to deal with multiple values.
(POP_WITH_MULTIPLE_VALUES): New macro.
(POP): Modify this macro to ignore multiple values.
(DISCARD_PRESERVING_MULTIPLE_VALUES): New macro.
(DISCARD): Modify this macro to ignore multiple values.
(TOP_WITH_MULTIPLE_VALUES): New macro.
(TOP_ADDRESS): New macro.
(TOP): Modify this macro to ignore multiple values.
(TOP_LVALUE): New macro.
(Bcall): Ignore multiple values where appropriate.
(Breturn): Pass back multiple values.
(Bdup): Preserve multiple values.
Use TOP_LVALUE with most bytecodes that assign anything to
anything.
(Bbind_multiple_value_limits, Bmultiple_value_call,
Bmultiple_value_list_internal, Bthrow): Implement the new
bytecodes.
(Bgotoifnilelsepop, Bgotoifnonnilelsepop, BRgotoifnilelsepop,
BRgotoifnonnilelsepop):
Discard any multiple values.
* callint.c (Fcall_interactively):
Ignore multiple values when calling #'eval, in two places.
* device-x.c (x_IO_error_handler):
* macros.c (pop_kbd_macro_event):
* eval.c (Fsignal):
* eval.c (flagged_a_squirmer):
Call throw_or_bomb_out, not Fthrow, now that the latter is a
special form.
* eval.c:
Make Qthrow, Qobsolete_throw available as symbols.
Provide multiple_value_current_limit, multiple-values-limit (the
latter as specified by Common Lisp.
* eval.c (For):
Ignore multiple values when comparing with Qnil, but pass any
multiple values back for the last arg.
* eval.c (Fand):
Ditto.
* eval.c (Fif):
Ignore multiple values when examining the result of the
condition.
* eval.c (Fcond):
Ignore multiple values when comparing what the clauses give, but
pass them back if a clause gave non-nil.
* eval.c (Fprog2):
Never pass back multiple values.
* eval.c (FletX, Flet):
Ignore multiple when evaluating what exactly symbols should be
bound to.
* eval.c (Fwhile):
Ignore multiple values when evaluating the test.
* eval.c (Fsetq, Fdefvar, Fdefconst):
Ignore multiple values.
* eval.c (Fthrow):
Declare this as a special form; ignore multiple values for TAG,
preserve them for VALUE.
* eval.c (throw_or_bomb_out):
Make this available to other files, now Fthrow is a special form.
* eval.c (Feval):
Ignore multiple values when calling a compiled function, a
non-special-form subr, or a lambda expression.
* eval.c (Ffuncall):
If we attempt to call #'throw (now a special form) as a function,
don't error, call #'obsolete-throw instead.
* eval.c (make_multiple_value, multiple_value_aset)
(multiple_value_aref, print_multiple_value, mark_multiple_value)
(size_multiple_value):
Implement the multiple_value type. Add a long comment describing
our implementation.
* eval.c (bind_multiple_value_limits):
New function, used by the bytecode and by #'multiple-value-call,
#'multiple-value-list-internal.
* eval.c (multiple_value_call):
New function, used by the bytecode and #'multiple-value-call.
* eval.c (Fmultiple_value_call):
New special form.
* eval.c (multiple_value_list_internal):
New function, used by the byte code and
#'multiple-value-list-internal.
* eval.c (Fmultiple_value_list_internal, Fmultiple_value_prog1):
New special forms.
* eval.c (Fvalues, Fvalues_list):
New Lisp functions.
* eval.c (values2):
New function, for C code returning multiple values.
* eval.c (syms_of_eval):
Make our new Lisp functions and symbols available.
* eval.c (multiple-values-limit):
Make this available to Lisp.
* event-msw.c (dde_eval_string):
* event-stream.c (execute_help_form):
* glade.c (connector):
* glyphs-widget.c (glyph_instantiator_to_glyph):
* glyphs.c (evaluate_xpm_color_symbols):
* gui-x.c (wv_set_evalable_slot, button_item_to_widget_value):
* gui.c (gui_item_value, gui_item_display_flush_left):
* lread.c (check_if_suppressed):
* menubar-gtk.c (menu_convert, menu_descriptor_to_widget_1):
* menubar-msw.c (populate_menu_add_item):
* print.c (Fwith_output_to_temp_buffer):
* symbols.c (Fsetq_default):
Ignore multiple values when calling Feval.
* symeval.h:
Add the header declarations necessary for the multiple-values
implementation.
* inline.c:
#include symeval.h, now that it has some inline functions.
* lisp.h:
Update Fthrow's declaration. Make throw_or_bomb_out available to
all files.
* lrecord.h (enum lrecord_type):
Add the multiple_value type here.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Sun, 16 Aug 2009 20:55:49 +0100 |
parents | f8d7d8202635 |
children | cdabd56ce1b5 |
line wrap: on
line diff
--- a/src/eval.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/eval.c Sun Aug 16 20:55:49 2009 +0100 @@ -241,6 +241,16 @@ Lisp_Object Vpending_warnings, Vpending_warnings_tail; Lisp_Object Qif; +Lisp_Object Qthrow; +Lisp_Object Qobsolete_throw; + +static int first_desired_multiple_value; +/* Used outside this file, somewhat uncleanly, in the IGNORE_MULTIPLE_VALUES + macro: */ +int multiple_value_current_limit; + +Fixnum Vmultiple_values_limit; + /* Flags specifying which operations are currently inhibited. */ int inhibit_flags; @@ -820,6 +830,9 @@ The remaining ARGS are not evalled at all. If all args return nil, return nil. +Any multiple values from the last form, and only from the last form, are +passed back. See `values' and `multiple-value-bind'. + arguments: (&rest ARGS) */ (args)) @@ -827,13 +840,21 @@ /* This function can GC */ REGISTER Lisp_Object val; - LIST_LOOP_2 (arg, args) + LIST_LOOP_3 (arg, args, tail) { - if (!NILP (val = Feval (arg))) - return val; + if (!NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) + { + if (NILP (XCDR (tail))) + { + /* Pass back multiple values if this is the last one: */ + return val; + } + + return IGNORE_MULTIPLE_VALUES (val); + } } - return Qnil; + return val; } DEFUN ("and", Fand, 0, UNEVALLED, 0, /* @@ -841,6 +862,9 @@ The remaining ARGS are not evalled at all. If no arg yields nil, return the last arg's value. +Any multiple values from the last form, and only from the last form, are +passed back. See `values' and `multiple-value-bind'. + arguments: (&rest ARGS) */ (args)) @@ -848,10 +872,18 @@ /* This function can GC */ REGISTER Lisp_Object val = Qt; - LIST_LOOP_2 (arg, args) + LIST_LOOP_3 (arg, args, tail) { - if (NILP (val = Feval (arg))) - return val; + if (NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) + { + if (NILP (XCDR (tail))) + { + /* Pass back any multiple values for the last form: */ + return val; + } + + return Qnil; + } } return val; @@ -872,7 +904,7 @@ Lisp_Object then_form = XCAR (XCDR (args)); Lisp_Object else_forms = XCDR (XCDR (args)); - if (!NILP (Feval (condition))) + if (!NILP (IGNORE_MULTIPLE_VALUES (Feval (condition)))) return Feval (then_form); else return Fprogn (else_forms); @@ -935,11 +967,12 @@ LIST_LOOP_2 (clause, args) { CHECK_CONS (clause); - if (!NILP (val = Feval (XCAR (clause)))) + if (!NILP (val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (clause))))) { if (!NILP (clause = XCDR (clause))) { CHECK_TRUE_LIST (clause); + /* Pass back any multiple values here: */ val = Fprogn (clause); } return val; @@ -988,7 +1021,7 @@ Lisp_Object val; struct gcpro gcpro1; - val = Feval (XCAR (args)); + val = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args))); GCPRO1 (val); @@ -1017,7 +1050,9 @@ Feval (XCAR (args)); args = XCDR (args); - val = Feval (XCAR (args)); + + val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); + args = XCDR (args); GCPRO1 (val); @@ -1062,7 +1097,7 @@ else { CHECK_CONS (tem); - value = Feval (XCAR (tem)); + value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); if (!NILP (XCDR (tem))) sferror ("`let' bindings can have only one value-form", var); @@ -1120,7 +1155,7 @@ else { CHECK_CONS (tem); - *value = Feval (XCAR (tem)); + *value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); gcpro1.nvars = idx; if (!NILP (XCDR (tem))) @@ -1157,7 +1192,7 @@ Lisp_Object test = XCAR (args); Lisp_Object body = XCDR (args); - while (!NILP (Feval (test))) + while (!NILP (IGNORE_MULTIPLE_VALUES (Feval (test)))) { QUIT; Fprogn (body); @@ -1189,6 +1224,7 @@ GC_PROPERTY_LIST_LOOP_3 (symbol, val, args) { val = Feval (val); + val = IGNORE_MULTIPLE_VALUES (val); Fset (symbol, val); retval = val; } @@ -1311,7 +1347,7 @@ { struct gcpro gcpro1; GCPRO1 (val); - val = Feval (val); + val = IGNORE_MULTIPLE_VALUES (Feval (val)); Fset_default (sym, val); UNGCPRO; } @@ -1361,6 +1397,8 @@ GCPRO1 (val); + val = IGNORE_MULTIPLE_VALUES (val); + Fset_default (sym, val); UNGCPRO; @@ -1663,10 +1701,10 @@ LONGJMP (c->jmp, 1); } -static DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int, - Lisp_Object, Lisp_Object)); - -static DOESNT_RETURN +DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int, + Lisp_Object, Lisp_Object)); + +DOESNT_RETURN throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p, Lisp_Object sig, Lisp_Object data) { @@ -1739,12 +1777,29 @@ condition_case_1). See below for more info. */ -DEFUN_NORETURN ("throw", Fthrow, 2, 2, 0, /* +DEFUN_NORETURN ("throw", Fthrow, 2, UNEVALLED, 0, /* Throw to the catch for TAG and return VALUE from it. -Both TAG and VALUE are evalled. Tags are the same iff they are `eq'. + +Both TAG and VALUE are evalled, and multiple values in VALUE will be passed +back. Tags are the same if and only if they are `eq'. + +arguments: (TAG VALUE) */ - (tag, value)) -{ + (args)) +{ + int nargs; + Lisp_Object tag, value; + + GET_LIST_LENGTH (args, nargs); + if (nargs != 2) + { + Fsignal (Qwrong_number_of_arguments, list2 (Qthrow, make_int (nargs))); + } + + tag = IGNORE_MULTIPLE_VALUES (Feval (XCAR(args))); + + value = Feval (XCAR (XCDR (args))); + throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */ RETURN_NOT_REACHED (Qnil); } @@ -2360,7 +2415,8 @@ else if (EQ (handler_data, Qt)) { UNGCPRO; - return Fthrow (handlers, Fcons (error_symbol, data)); + throw_or_bomb_out (handlers, Fcons (error_symbol, data), + 0, Qnil, Qnil); } /* `error' is used similarly to the way `t' is used, but in addition it invokes the debugger if debug_on_error. @@ -2379,7 +2435,7 @@ return return_from_signal (tem); tem = Fcons (error_symbol, data); - return Fthrow (handlers, tem); + throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); } else { @@ -2403,7 +2459,7 @@ /* Doesn't return */ tem = Fcons (Fcons (error_symbol, data), Fcdr (clause)); - return Fthrow (handlers, tem); + throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); } } } @@ -3665,7 +3721,7 @@ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } @@ -3696,7 +3752,7 @@ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } @@ -3729,7 +3785,7 @@ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } @@ -3778,7 +3834,7 @@ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } @@ -3958,6 +4014,12 @@ } else if (max_args == UNEVALLED) /* Can't funcall a special form */ { + /* Ugh, ugh, ugh. */ + if (EQ (fun, XSYMBOL_FUNCTION (Qthrow))) + { + args[0] = Qobsolete_throw; + goto retry; + } goto invalid_function; } else @@ -4238,7 +4300,6 @@ } } - /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and return the result of evaluation. */ @@ -4296,6 +4357,590 @@ } +/* Multiple values. + + A multiple value object is returned by #'values if: + + -- The number of arguments to #'values is not one, and: + -- Some special form in the call stack is prepared to handle more than + one multiple value. + + The return value of #'values-list is analogous to that of #'values. + + Henry Baker, in https://eprints.kfupm.edu.sa/31898/1/31898.pdf ("CONS + Should not CONS its Arguments, or, a Lazy Alloc is a Smart Alloc", ACM + Sigplan Notices 27,3 (March 1992),24-34.) says it should be possible to + allocate Common Lisp multiple-value objects on the stack, but this + assumes that variable-length records can be allocated on the stack, + something not true for us. As far as I can tell, it also ignores the + contexts where multiple-values need to be thrown, or maybe it thinks such + objects should be converted to heap allocation at that point. + + The specific multiple values saved and returned depend on how many + multiple-values special forms in the stack are interested in; for + example, if #'multiple-value-call is somewhere in the call stack, all + values passed to #'values will be saved and returned. If an expansion of + #'multiple-value-setq with 10 SYMS is the only part of the call stack + interested in multiple values, then a maximum of ten multiple values will + be saved and returned. + + (#'throw passes back multiple values in its VALUE argument; this is why + we can't just take the details of the most immediate + #'multiple-value-{whatever} call to work out which values to save, we + need to look at the whole stack, or, equivalently, the dynamic variables + we set to reflect the whole stack.) + + The first value passed to #'values will always be saved, since that is + needed to convert a multiple value object into a single value object, + something that is normally necessary independent of how many functions in + the call stack are interested in multiple values. + + However many values (for values of "however many" that are not one) are + saved and restored, the multiple value object knows how many arguments it + would contain were none to have been discarded, and will indicate this + on being printed from within GDB. + + In lisp-interaction-mode, no multiple values should be discarded (unless + they need to be for the sake of the correctness of the program); + #'eval-interactive-with-multiple-value-list in lisp-mode.el wraps its + #'eval calls with #'multiple-value-list calls to avoid this. This means + that there is a small performance and memory penalty for code evaluated + in *scratch*; use M-: EXPRESSION RET if you really need to avoid + this. Lisp code execution that is not ultimately from hitting C-j in + *scratch*--that is, the vast vast majority of Lisp code execution--does + not have this penalty. + + Probably the most important aspect of multiple values is stated with + admirable clarity by CLTL2: + + "No matter how many values a form produces, if the form is an argument + form in a function call, then exactly one value (the first one) is + used." + + This means that most contexts, most of the time, will never see multiple + values. There are important exceptions; search the web for that text in + quotation marks and read the related chapter. This code handles all of + them, to my knowledge. Aidan Kehoe, Mon Mar 16 00:17:39 GMT 2009. */ + +static Lisp_Object +make_multiple_value (Lisp_Object first_value, Elemcount count, + Elemcount first_desired, Elemcount upper_limit) +{ + Bytecount sizem; + struct multiple_value *mv; + Elemcount i, allocated_count; + + assert (count != 1); + + if (1 != upper_limit && (0 == first_desired)) + { + /* We always allocate element zero, and that's taken into account when + working out allocated_count: */ + first_desired = 1; + } + + if (first_desired >= count) + { + /* We can't pass anything back that our caller is interested in. Only + allocate for the first argument. */ + allocated_count = 1; + } + else + { + allocated_count = 1 + ((upper_limit > count ? count : upper_limit) + - first_desired); + } + + sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (multiple_value, + Lisp_Object, + contents, allocated_count); + mv = (multiple_value *) BASIC_ALLOC_LCRECORD (sizem, + &lrecord_multiple_value); + + mv->count = count; + mv->first_desired = first_desired; + mv->allocated_count = allocated_count; + mv->contents[0] = first_value; + + for (i = first_desired; i < upper_limit && i < count; ++i) + { + mv->contents[1 + (i - first_desired)] = Qunbound; + } + + return wrap_multiple_value (mv); +} + +void +multiple_value_aset (Lisp_Object obj, Elemcount index, Lisp_Object value) +{ + struct multiple_value *mv = XMULTIPLE_VALUE (obj); + Elemcount first_desired = mv->first_desired; + Elemcount allocated_count = mv->allocated_count; + + if (index != 0 && + (index < first_desired || index >= (first_desired + allocated_count))) + { + args_out_of_range (make_int (first_desired), + make_int (first_desired + allocated_count)); + } + + mv->contents[index == 0 ? 0 : 1 + (index - first_desired)] = value; +} + +Lisp_Object +multiple_value_aref (Lisp_Object obj, Elemcount index) +{ + struct multiple_value *mv = XMULTIPLE_VALUE (obj); + Elemcount first_desired = mv->first_desired; + Elemcount allocated_count = mv->allocated_count; + + if (index != 0 && + (index < first_desired || index >= (first_desired + allocated_count))) + { + args_out_of_range (make_int (first_desired), + make_int (first_desired + allocated_count)); + } + + return mv->contents[index == 0 ? 0 : 1 + (index - first_desired)]; +} + +static void +print_multiple_value (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + struct multiple_value *mv = XMULTIPLE_VALUE (obj); + Elemcount first_desired = mv->first_desired; + Elemcount allocated_count = mv->allocated_count; + Elemcount count = mv->count, index; + + if (print_readably) + { + printing_unreadable_object ("multiple values"); + } + + if (0 == count) + { + write_c_string (printcharfun, "#<zero-length multiple value>"); + } + + for (index = 0; index < count;) + { + if (index != 0 && + (index < first_desired || + index >= (first_desired + (allocated_count - 1)))) + { + write_fmt_string (printcharfun, "#<discarded-multiple-value %d>", + index); + } + else + { + print_internal (multiple_value_aref (obj, index), + printcharfun, escapeflag); + } + + ++index; + + if (count > 1 && index < count) + { + write_c_string (printcharfun, " ;\n"); + } + } +} + +static Lisp_Object +mark_multiple_value (Lisp_Object obj) +{ + struct multiple_value *mv = XMULTIPLE_VALUE (obj); + Elemcount index, allocated_count = mv->allocated_count; + + for (index = 0; index < allocated_count; ++index) + { + mark_object (mv->contents[index]); + } + + return Qnil; +} + +static Bytecount +size_multiple_value (const void *lheader) +{ + return FLEXIBLE_ARRAY_STRUCT_SIZEOF (struct multiple_value, + Lisp_Object, contents, + ((struct multiple_value *) lheader)-> + allocated_count); +} + +static const struct memory_description multiple_value_description[] = { + { XD_LONG, offsetof (struct multiple_value, count) }, + { XD_ELEMCOUNT, offsetof (struct multiple_value, allocated_count) }, + { XD_LONG, offsetof (struct multiple_value, first_desired) }, + { XD_LISP_OBJECT_ARRAY, offsetof (struct multiple_value, contents), + XD_INDIRECT (1, 0) }, + { XD_END } +}; + +DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("multiple-value", multiple_value, + 1, /*dumpable-flag*/ + mark_multiple_value, + print_multiple_value, 0, + 0, /* No equal method. */ + 0, /* No hash method. */ + multiple_value_description, + size_multiple_value, + struct multiple_value); + +/* Given that FIRST and UPPER are the inclusive lower and exclusive upper + bounds for the multiple values we're interested in, modify (or don't) the + special variables used to indicate this to #'values and #'values-list. + Returns the specpdl_depth() value before any modification. */ +int +bind_multiple_value_limits (int first, int upper) +{ + int result = specpdl_depth(); + + if (!(upper > first)) + { + invalid_argument ("MULTIPLE-VALUE-UPPER-LIMIT must be greater than " + " FIRST-DESIRED-MULTIPLE-VALUE", Qunbound); + } + + if (upper > Vmultiple_values_limit) + { + args_out_of_range (make_int (upper), make_int (Vmultiple_values_limit)); + } + + /* In the event that something back up the stack wants more multiple + values than we do, we need to keep its figures for + first_desired_multiple_value or multiple_value_current_limit both. It + may be that the form will throw past us. + + If first_desired_multiple_value is zero, this means it hasn't ever been + bound, and any value we have for first is appropriate to use. + + Zeroth element is always saved, no need to note that: */ + if (0 == first) + { + first = 1; + } + + if (0 == first_desired_multiple_value + || first < first_desired_multiple_value) + { + internal_bind_int (&first_desired_multiple_value, first); + } + + if (upper > multiple_value_current_limit) + { + internal_bind_int (&multiple_value_current_limit, upper); + } + + return result; +} + +Lisp_Object +multiple_value_call (int nargs, Lisp_Object *args) +{ + /* The argument order here is horrible: */ + int i, speccount = XINT (args[3]); + Lisp_Object result = Qnil, head = Fcons (args[0], Qnil), list_offset; + struct gcpro gcpro1, gcpro2; + Lisp_Object apply_args[2]; + + GCPRO2 (head, result); + list_offset = head; + + assert (!(MULTIPLE_VALUEP (args[0]))); + CHECK_FUNCTION (args[0]); + + /* Start at 4, to ignore the function, the speccount, and the arguments to + multiple-values-limit (which we don't discard because + #'multiple-value-list-internal needs them): */ + for (i = 4; i < nargs; ++i) + { + result = args[i]; + if (MULTIPLE_VALUEP (result)) + { + Lisp_Object val; + Elemcount i, count = XMULTIPLE_VALUE_COUNT (result); + + for (i = 0; i < count; i++) + { + val = multiple_value_aref (result, i); + assert (!UNBOUNDP (val)); + + XSETCDR (list_offset, Fcons (val, Qnil)); + list_offset = XCDR (list_offset); + } + } + else + { + XSETCDR (list_offset, Fcons (result, Qnil)); + list_offset = XCDR (list_offset); + } + } + + apply_args [0] = XCAR (head); + apply_args [1] = XCDR (head); + + unbind_to (speccount); + + RETURN_UNGCPRO (Fapply (countof(apply_args), apply_args)); +} + +DEFUN ("multiple-value-call", Fmultiple_value_call, 1, UNEVALLED, 0, /* +Call FUNCTION with arguments FORMS, using multiple values when returned. + +All of the (possibly multiple) values returned by each form in FORMS are +gathered together, and given as arguments to FUNCTION; conceptually, this +function is a version of `apply' that by-passes the multiple values +infrastructure, treating multiple values as intercalated lists. + +arguments: (FUNCTION &rest FORMS) +*/ + (args)) +{ + int listcount, i = 0, speccount; + Lisp_Object *constructed_args; + struct gcpro gcpro1; + + GET_EXTERNAL_LIST_LENGTH (args, listcount); + + constructed_args = alloca_array (Lisp_Object, listcount + 3); + + /* Fcar so we error on non-cons: */ + constructed_args[i] = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args))); + + GCPRO1 (*constructed_args); + gcpro1.nvars = ++i; + + /* The argument order is horrible here. */ + constructed_args[i] = make_int (0); + gcpro1.nvars = ++i; + constructed_args[i] = make_int (Vmultiple_values_limit); + gcpro1.nvars = ++i; + + speccount = bind_multiple_value_limits (0, Vmultiple_values_limit); + constructed_args[i] = make_int (speccount); + gcpro1.nvars = ++i; + + { + LIST_LOOP_2 (elt, XCDR (args)) + { + constructed_args[i] = Feval (elt); + gcpro1.nvars = ++i; + } + } + + RETURN_UNGCPRO (multiple_value_call (listcount + 3, constructed_args)); +} + +Lisp_Object +multiple_value_list_internal (int nargs, Lisp_Object *args) +{ + int first = XINT (args[0]), upper = XINT (args[1]), + speccount = XINT(args[2]); + Lisp_Object result = Qnil; + + assert (nargs == 4); + + result = args[3]; + + unbind_to (speccount); + + if (MULTIPLE_VALUEP (result)) + { + Lisp_Object head = Fcons (Qnil, Qnil); + Lisp_Object list_offset = head, val; + Elemcount count = XMULTIPLE_VALUE_COUNT(result); + + for (; first < upper && first < count; ++first) + { + val = multiple_value_aref (result, first); + assert (!UNBOUNDP (val)); + + XSETCDR (list_offset, Fcons (val, Qnil)); + list_offset = XCDR (list_offset); + } + + return XCDR (head); + } + else + { + if (first == 0) + { + return Fcons (result, Qnil); + } + else + { + return Qnil; + } + } +} + +DEFUN ("multiple-value-list-internal", Fmultiple_value_list_internal, 3, + UNEVALLED, 0, /* +Evaluate FORM. Return a list of multiple vals reflecting the other two args. + +Don't use this. Use `multiple-value-list', the macro specified by Common +Lisp, instead. + +FIRST-DESIRED-MULTIPLE-VALUE is the first element in list of multiple values +to pass back. MULTIPLE-VALUE-UPPER-LIMIT is the exclusive upper limit on +the indexes within the values that may be passed back; this function will +never return a list longer than MULTIPLE-VALUE-UPPER-LIMIT - +FIRST-DESIRED-MULTIPLE-VALUE. It may return a list shorter than that, if +`values' or `values-list' do not supply enough elements. + +arguments: (FIRST-DESIRED-MULTIPLE-VALUE MULTIPLE-VALUE-UPPER-LIMIT FORM) +*/ + (args)) +{ + Lisp_Object argv[4]; + int first, upper; + struct gcpro gcpro1; + + argv[0] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); + CHECK_NATNUM (argv[0]); + first = XINT (argv[0]); + + GCPRO1 (argv[0]); + gcpro1.nvars = 1; + + args = XCDR (args); + + argv[1] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); + CHECK_NATNUM (argv[1]); + upper = XINT (argv[1]); + gcpro1.nvars = 2; + + /* The unintuitive order of things here is for the sake of the bytecode; + the alternative would be to encode the number of arguments in the + bytecode stream, which complicates things if we have more than 255 + arguments. */ + argv[2] = make_int (bind_multiple_value_limits (first, upper)); + gcpro1.nvars = 3; + args = XCDR (args); + + /* GCPROing in this function is not strictly necessary, this Feval is the + only point that may cons up data that is not immediately discarded, and + within it is the only point (in Fmultiple_value_list_internal and + multiple_value_list) that we can garbage collect. But I'm conservative, + and this function is called so rarely (only from interpreted code) that + it doesn't matter for performance. */ + argv[3] = Feval (XCAR (args)); + gcpro1.nvars = 4; + + RETURN_UNGCPRO (multiple_value_list_internal (countof (argv), argv)); +} + +DEFUN ("multiple-value-prog1", Fmultiple_value_prog1, 1, UNEVALLED, 0, /* +Similar to `prog1', but return any multiple values from the first form. +`prog1' itself will never return multiple values. + +arguments: (FIRST &rest BODY) +*/ + (args)) +{ + /* This function can GC */ + Lisp_Object val; + struct gcpro gcpro1; + + val = Feval (XCAR (args)); + + GCPRO1 (val); + + { + LIST_LOOP_2 (form, XCDR (args)) + Feval (form); + } + + RETURN_UNGCPRO (val); +} + +DEFUN ("values", Fvalues, 0, MANY, 0, /* +Return all ARGS as multiple values. + +arguments: (&rest ARGS) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object result = Qnil; + int counting = 1; + + /* Pathological cases, no need to cons up an object: */ + if (1 == nargs || 1 == multiple_value_current_limit) + { + return nargs ? args[0] : Qnil; + } + + /* If nargs is zero, this code is correct and desirable. With + #'multiple-value-call, we want zero-length multiple values in the + argument list to be discarded entirely, and we can't do this if we + transform them to nil. */ + result = make_multiple_value (nargs ? args[0] : Qnil, nargs, + first_desired_multiple_value, + multiple_value_current_limit); + + for (; counting < nargs; ++counting) + { + if (counting >= first_desired_multiple_value && + counting < multiple_value_current_limit) + { + multiple_value_aset (result, counting, args[counting]); + } + } + + return result; +} + +DEFUN ("values-list", Fvalues_list, 1, 1, 0, /* +Return all the elements of LIST as multiple values. +*/ + (list)) +{ + Lisp_Object result = Qnil; + int counting = 1, listcount; + + GET_EXTERNAL_LIST_LENGTH (list, listcount); + + /* Pathological cases, no need to cons up an object: */ + if (1 == listcount || 1 == multiple_value_current_limit) + { + return Fcar_safe (list); + } + + result = make_multiple_value (Fcar_safe (list), listcount, + first_desired_multiple_value, + multiple_value_current_limit); + + list = Fcdr_safe (list); + + { + EXTERNAL_LIST_LOOP_2 (elt, list) + { + if (counting >= first_desired_multiple_value && + counting < multiple_value_current_limit) + { + multiple_value_aset (result, counting, elt); + } + ++counting; + } + } + + return result; +} + +Lisp_Object +values2 (Lisp_Object first, Lisp_Object second) +{ + Lisp_Object argv[2]; + + argv[0] = first; + argv[1] = second; + + return Fvalues (countof (argv), argv); +} + + /************************************************************************/ /* Run hook variables in various ways. */ /************************************************************************/ @@ -4968,7 +5613,7 @@ p->error_conditions = error_conditions; p->data = data; - Fthrow (p->catchtag, Qnil); + throw_or_bomb_out (p->catchtag, Qnil, 0, Qnil, Qnil); RETURN_NOT_REACHED (Qnil); } @@ -6555,6 +7200,7 @@ syms_of_eval (void) { INIT_LRECORD_IMPLEMENTATION (subr); + INIT_LRECORD_IMPLEMENTATION (multiple_value); DEFSYMBOL (Qinhibit_quit); DEFSYMBOL (Qautoload); @@ -6578,6 +7224,8 @@ DEFSYMBOL (Qrun_hooks); DEFSYMBOL (Qfinalize_list); DEFSYMBOL (Qif); + DEFSYMBOL (Qthrow); + DEFSYMBOL (Qobsolete_throw); DEFSUBR (For); DEFSUBR (Fand); @@ -6611,6 +7259,11 @@ DEFSUBR (Fautoload); DEFSUBR (Feval); DEFSUBR (Fapply); + DEFSUBR (Fmultiple_value_call); + DEFSUBR (Fmultiple_value_list_internal); + DEFSUBR (Fmultiple_value_prog1); + DEFSUBR (Fvalues); + DEFSUBR (Fvalues_list); DEFSUBR (Ffuncall); DEFSUBR (Ffunctionp); DEFSUBR (Ffunction_min_args); @@ -6636,6 +7289,9 @@ debug_on_next_call = 0; lisp_eval_depth = 0; entering_debugger = 0; + + first_desired_multiple_value = 0; + multiple_value_current_limit = 1; } void @@ -6805,6 +7461,14 @@ */ ); Vdebugger = Qnil; + DEFVAR_CONST_INT ("multiple-values-limit", &Vmultiple_values_limit /* +The exclusive upper bound on the number of multiple values. + +This applies to `values', `values-list', `multiple-value-bind' and related +macros and special forms. +*/); + Vmultiple_values_limit = EMACS_INT_MAX > INT_MAX ? INT_MAX : EMACS_INT_MAX; + staticpro (&Vcatch_everything_tag); Vcatch_everything_tag = make_opaque (OPAQUE_CLEAR, 0);