X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/647e35e27c4073bf1c07aa877e01450b86acab6e..8cb0d6d7fa9aaac316c29a64c541336b51b6f93d:/libguile/values.c diff --git a/libguile/values.c b/libguile/values.c dissimilarity index 72% index 59638174b..ef27cadd1 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -1,154 +1,156 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - -#include "libguile/_scm.h" -#include "libguile/eval.h" -#include "libguile/feature.h" -#include "libguile/gc.h" -#include "libguile/numbers.h" -#include "libguile/ports.h" -#include "libguile/root.h" -#include "libguile/strings.h" -#include "libguile/struct.h" -#include "libguile/validate.h" - -#include "libguile/values.h" - -static SCM values_vtable; - -#define SCM_VALUESP(x) (SCM_STRUCTP (x)\ - && SCM_EQ_P (scm_struct_vtable (x), values_vtable)) - -static SCM -print_values (SCM obj, SCM pwps) -{ - SCM values = scm_struct_ref (obj, SCM_INUM0); - SCM port = SCM_PORT_WITH_PS_PORT (pwps); - scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps)); - - while (SCM_CONSP (values)) - { - scm_iprin1 (SCM_CAR (values), port, ps); - values = SCM_CDR (values); - if (SCM_CONSP (values)) - scm_newline (port); - } - return SCM_UNSPECIFIED; -} - -SCM_DEFINE (scm_values, "values", 0, 0, 1, - (SCM args), - "Delivers all of its arguments to its continuation. Except for\n" - "continuations created by the @code{call-with-values} procedure,\n" - "all continuations take exactly one value. The effect of\n" - "passing no value or more than one value to continuations that\n" - "were not created by @code{call-with-values} is unspecified.") -#define FUNC_NAME s_scm_values -{ - long n; - SCM result; - - SCM_VALIDATE_LIST_COPYLEN (1, args, n); - if (n == 1) - result = SCM_CAR (args); - else - { - result = scm_make_struct (values_vtable, SCM_INUM0, - scm_cons (args, SCM_EOL)); - } - - return result; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_call_with_values, "call-with-values", 2, 0, 0, - (SCM producer, SCM consumer), - "Calls its @var{producer} argument with no values and a\n" - "continuation that, when passed some values, calls the\n" - "@var{consumer} procedure with those values as arguments. The\n" - "continuation for the call to @var{consumer} is the continuation\n" - "of the call to @code{call-with-values}.\n\n" - "@example\n" - "(call-with-values (lambda () (values 4 5))\n" - " (lambda (a b) b))\n" - " ==> 5\n\n" - "@end example\n" - "@example\n" - "(call-with-values * -) ==> -1\n" - "@end example") -#define FUNC_NAME s_scm_call_with_values -{ - SCM product; - - SCM_VALIDATE_PROC (1, producer); - SCM_VALIDATE_PROC (2, consumer); - - product = scm_apply (producer, SCM_EOL, SCM_EOL); - if (SCM_VALUESP (product)) - product = scm_struct_ref (product, SCM_INUM0); - else - product = scm_cons (product, SCM_EOL); - return scm_apply (consumer, product, SCM_EOL); -} -#undef FUNC_NAME - -void -scm_init_values (void) -{ - SCM print = scm_make_subr ("%print-values", scm_tc7_subr_2, print_values); - - values_vtable - = scm_permanent_object (scm_make_vtable_vtable (scm_makfrom0str ("pr"), - SCM_INUM0, SCM_EOL)); - SCM_SET_STRUCT_PRINTER (values_vtable, print); - - scm_add_feature ("values"); - -#ifndef SCM_MAGIC_SNARFER -#include "libguile/values.x" -#endif -} - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ +/* Copyright (C) 2000, 2001, 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include "libguile/_scm.h" +#include "libguile/eval.h" +#include "libguile/feature.h" +#include "libguile/gc.h" +#include "libguile/numbers.h" +#include "libguile/ports.h" +#include "libguile/root.h" +#include "libguile/strings.h" +#include "libguile/struct.h" +#include "libguile/validate.h" + +#include "libguile/values.h" + +SCM scm_values_vtable; + +/* OBJ must be a values object containing exactly two values. + scm_i_extract_values_2 puts those two values into *p1 and *p2. */ +void +scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2) +{ + SCM values; + + SCM_ASSERT_TYPE (SCM_VALUESP (obj), obj, SCM_ARG1, + "scm_i_extract_values_2", "values"); + values = scm_struct_ref (obj, SCM_INUM0); + if (scm_ilength (values) != 2) + scm_wrong_type_arg_msg + ("scm_i_extract_values_2", SCM_ARG1, obj, + "a values object containing exactly two values"); + *p1 = SCM_CAR (values); + *p2 = SCM_CADR (values); +} + +static SCM +print_values (SCM obj, SCM pwps) +{ + SCM values = scm_struct_ref (obj, SCM_INUM0); + SCM port = SCM_PORT_WITH_PS_PORT (pwps); + scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps)); + + scm_puts ("#", port); + + return SCM_UNSPECIFIED; +} + +size_t +scm_c_nvalues (SCM obj) +{ + if (SCM_LIKELY (SCM_VALUESP (obj))) + return scm_ilength (scm_struct_ref (obj, SCM_INUM0)); + else + return 1; +} + +SCM +scm_c_value_ref (SCM obj, size_t idx) +{ + if (SCM_LIKELY (SCM_VALUESP (obj))) + { + SCM values = scm_struct_ref (obj, SCM_INUM0); + size_t i = idx; + while (SCM_LIKELY (scm_is_pair (values))) + { + if (i == 0) + return SCM_CAR (values); + values = SCM_CDR (values); + i--; + } + } + else if (idx == 0) + return obj; + + scm_error (scm_out_of_range_key, + "scm_c_value_ref", + "Too few values in ~S to access index ~S", + scm_list_2 (obj, scm_from_size_t (idx)), + scm_list_1 (scm_from_size_t (idx))); +} + +SCM_DEFINE (scm_values, "values", 0, 0, 1, + (SCM args), + "Delivers all of its arguments to its continuation. Except for\n" + "continuations created by the @code{call-with-values} procedure,\n" + "all continuations take exactly one value. The effect of\n" + "passing no value or more than one value to continuations that\n" + "were not created by @code{call-with-values} is unspecified.") +#define FUNC_NAME s_scm_values +{ + long n; + SCM result; + + SCM_VALIDATE_LIST_COPYLEN (1, args, n); + if (n == 1) + result = SCM_CAR (args); + else + result = scm_c_make_struct (scm_values_vtable, 0, 1, SCM_UNPACK (args)); + + return result; +} +#undef FUNC_NAME + +SCM +scm_c_values (SCM *base, size_t nvalues) +{ + SCM ret, *walk; + + if (nvalues == 1) + return *base; + + for (ret = SCM_EOL, walk = base + nvalues - 1; walk >= base; walk--) + ret = scm_cons (*walk, ret); + + return scm_values (ret); +} + +void +scm_init_values (void) +{ + SCM print = scm_c_define_gsubr ("%print-values", 2, 0, 0, print_values); + + scm_values_vtable = scm_make_vtable (scm_from_locale_string ("pr"), print); + + scm_add_feature ("values"); + +#include "libguile/values.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/