summaryrefslogtreecommitdiff
path: root/libguile/values.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/values.c')
-rw-r--r--libguile/values.c166
1 files changed, 87 insertions, 79 deletions
diff --git a/libguile/values.c b/libguile/values.c
index 131784a4e..522a8f5e5 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -1,77 +1,57 @@
-/* Copyright (C) 2000, 2001, 2006, 2008, 2009, 2011-2013, 2016, 2018
- * 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
- */
+/* Copyright 2000-2001,2006,2008-2009,2011-2013,2016-2019
+ Free Software Foundation, Inc.
+
+ This file is part of Guile.
+
+ Guile 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.
+
+ Guile 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 Guile. If not, see
+ <https://www.gnu.org/licenses/>. */
#ifdef HAVE_CONFIG_H
# include <config.h>
#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/strings.h"
-#include "libguile/struct.h"
-#include "libguile/validate.h"
+#include "feature.h"
+#include "gc.h"
+#include "gsubr.h"
+#include "list.h"
+#include "numbers.h"
+#include "pairs.h"
-#include "libguile/values.h"
+#include "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_ASSERT_TYPE (scm_is_values (obj), obj, SCM_ARG1,
"scm_i_extract_values_2", "values");
- values = scm_struct_ref (obj, SCM_INUM0);
- if (scm_ilength (values) != 2)
+ if (scm_i_nvalues (obj) != 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 ("#<values ", port);
- scm_iprin1 (values, port, ps);
- scm_puts (">", port);
- return SCM_UNSPECIFIED;
+ *p1 = scm_i_value_ref (obj, 0);
+ *p2 = scm_i_value_ref (obj, 1);
}
size_t
scm_c_nvalues (SCM obj)
{
- if (SCM_LIKELY (SCM_VALUESP (obj)))
- return scm_ilength (scm_struct_ref (obj, SCM_INUM0));
+ if (SCM_LIKELY (scm_is_values (obj)))
+ return scm_i_nvalues (obj);
else
return 1;
}
@@ -79,20 +59,16 @@ scm_c_nvalues (SCM obj)
SCM
scm_c_value_ref (SCM obj, size_t idx)
{
- if (SCM_LIKELY (SCM_VALUESP (obj)))
+ if (scm_is_values (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--;
- }
+ if (idx < scm_i_nvalues (obj))
+ return scm_i_value_ref (obj, idx);
+ }
+ else
+ {
+ if (idx == 0)
+ return obj;
}
- else if (idx == 0)
- return obj;
scm_error (scm_out_of_range_key,
"scm_c_value_ref",
@@ -117,7 +93,17 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1,
if (n == 1)
result = SCM_CAR (args);
else
- result = scm_c_make_struct (scm_values_vtable, 0, 1, SCM_UNPACK (args));
+ {
+ size_t i;
+
+ if ((size_t) n > (size_t) (UINTPTR_MAX >> 8))
+ scm_error (scm_out_of_range_key, FUNC_NAME, "Too many values",
+ SCM_EOL, SCM_EOL);
+
+ result = scm_words ((((scm_t_bits) n) << 8) | scm_tc7_values, n + 1);
+ for (i = 0; i < n; i++, args = SCM_CDR (args))
+ SCM_SET_CELL_OBJECT (result, i + 1, SCM_CAR (args));
+ }
return result;
}
@@ -126,31 +112,53 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1,
SCM
scm_c_values (SCM *base, size_t nvalues)
{
- SCM ret, *walk;
+ SCM ret;
+ size_t i;
if (nvalues == 1)
return *base;
- for (ret = SCM_EOL, walk = base + nvalues - 1; walk >= base; walk--)
- ret = scm_cons (*walk, ret);
+ if ((uintptr_t) nvalues > (UINTPTR_MAX >> 8))
+ scm_error (scm_out_of_range_key, "scm_c_values", "Too many values",
+ SCM_EOL, SCM_EOL);
+
+ ret = scm_words ((((scm_t_bits) nvalues) << 8) | scm_tc7_values, nvalues + 1);
- return scm_values (ret);
+ for (i = 0; i < nvalues; i++)
+ SCM_SET_CELL_OBJECT (ret, i + 1, base[i]);
+
+ return ret;
}
-void
-scm_init_values (void)
+SCM
+scm_values_2 (SCM a, SCM b)
{
- SCM print = scm_c_define_gsubr ("%print-values", 2, 0, 0, print_values);
+ SCM ret;
- scm_values_vtable = scm_make_vtable (scm_from_utf8_string ("pr"), print);
+ ret = scm_words ((2 << 8) | scm_tc7_values, 3);
+ SCM_SET_CELL_OBJECT_1 (ret, a);
+ SCM_SET_CELL_OBJECT_2 (ret, b);
- scm_add_feature ("values");
+ return ret;
+}
+
+SCM
+scm_values_3 (SCM a, SCM b, SCM c)
+{
+ SCM ret;
+
+ ret = scm_words ((3 << 8) | scm_tc7_values, 4);
+ SCM_SET_CELL_OBJECT_1 (ret, a);
+ SCM_SET_CELL_OBJECT_2 (ret, b);
+ SCM_SET_CELL_OBJECT_3 (ret, c);
-#include "libguile/values.x"
+ return ret;
}
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+void
+scm_init_values (void)
+{
+ scm_add_feature ("values");
+
+#include "values.x"
+}