1 /* Copyright 2000-2001,2006,2008-2009,2011-2013,2016-2019
2 Free Software Foundation, Inc.
3
4 This file is part of Guile.
5
6 Guile is free software: you can redistribute it and/or modify it
7 under the terms of the GNU Lesser General Public License as published
8 by the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
10
11 Guile is distributed in the hope that it will be useful, but WITHOUT
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
14 License for more details.
15
16 You should have received a copy of the GNU Lesser General Public
17 License along with Guile. If not, see
18 <https://www.gnu.org/licenses/>. */
19
20 #ifdef HAVE_CONFIG_H
21 # include <config.h>
22 #endif
23
24 #include "feature.h"
25 #include "gc.h"
26 #include "gsubr.h"
27 #include "list.h"
28 #include "numbers.h"
29 #include "pairs.h"
30
31 #include "values.h"
32
33
34 /* OBJ must be a values object containing exactly two values.
35 scm_i_extract_values_2 puts those two values into *p1 and *p2. */
36 void
scm_i_extract_values_2(SCM obj,SCM * p1,SCM * p2)37 scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2)
38 {
39 SCM_ASSERT_TYPE (scm_is_values (obj), obj, SCM_ARG1,
40 "scm_i_extract_values_2", "values");
41 if (scm_i_nvalues (obj) != 2)
42 scm_wrong_type_arg_msg
43 ("scm_i_extract_values_2", SCM_ARG1, obj,
44 "a values object containing exactly two values");
45
46 *p1 = scm_i_value_ref (obj, 0);
47 *p2 = scm_i_value_ref (obj, 1);
48 }
49
50 size_t
scm_c_nvalues(SCM obj)51 scm_c_nvalues (SCM obj)
52 {
53 if (SCM_LIKELY (scm_is_values (obj)))
54 return scm_i_nvalues (obj);
55 else
56 return 1;
57 }
58
59 SCM
scm_c_value_ref(SCM obj,size_t idx)60 scm_c_value_ref (SCM obj, size_t idx)
61 {
62 if (scm_is_values (obj))
63 {
64 if (idx < scm_i_nvalues (obj))
65 return scm_i_value_ref (obj, idx);
66 }
67 else
68 {
69 if (idx == 0)
70 return obj;
71 }
72
73 scm_error (scm_out_of_range_key,
74 "scm_c_value_ref",
75 "Too few values in ~S to access index ~S",
76 scm_list_2 (obj, scm_from_size_t (idx)),
77 scm_list_1 (scm_from_size_t (idx)));
78 }
79
80 SCM_DEFINE (scm_values, "values", 0, 0, 1,
81 (SCM args),
82 "Delivers all of its arguments to its continuation. Except for\n"
83 "continuations created by the @code{call-with-values} procedure,\n"
84 "all continuations take exactly one value. The effect of\n"
85 "passing no value or more than one value to continuations that\n"
86 "were not created by @code{call-with-values} is unspecified.")
87 #define FUNC_NAME s_scm_values
88 {
89 long n;
90 SCM result;
91
92 SCM_VALIDATE_LIST_COPYLEN (1, args, n);
93 if (n == 1)
94 result = SCM_CAR (args);
95 else
96 {
97 size_t i;
98
99 if ((size_t) n > (size_t) (UINTPTR_MAX >> 8))
100 scm_error (scm_out_of_range_key, FUNC_NAME, "Too many values",
101 SCM_EOL, SCM_EOL);
102
103 result = scm_words ((((scm_t_bits) n) << 8) | scm_tc7_values, n + 1);
104 for (i = 0; i < n; i++, args = SCM_CDR (args))
105 SCM_SET_CELL_OBJECT (result, i + 1, SCM_CAR (args));
106 }
107
108 return result;
109 }
110 #undef FUNC_NAME
111
112 SCM
scm_c_values(SCM * base,size_t nvalues)113 scm_c_values (SCM *base, size_t nvalues)
114 {
115 SCM ret;
116 size_t i;
117
118 if (nvalues == 1)
119 return *base;
120
121 if ((uintptr_t) nvalues > (UINTPTR_MAX >> 8))
122 scm_error (scm_out_of_range_key, "scm_c_values", "Too many values",
123 SCM_EOL, SCM_EOL);
124
125 ret = scm_words ((((scm_t_bits) nvalues) << 8) | scm_tc7_values, nvalues + 1);
126
127 for (i = 0; i < nvalues; i++)
128 SCM_SET_CELL_OBJECT (ret, i + 1, base[i]);
129
130 return ret;
131 }
132
133 SCM
scm_values_2(SCM a,SCM b)134 scm_values_2 (SCM a, SCM b)
135 {
136 SCM ret;
137
138 ret = scm_words ((2 << 8) | scm_tc7_values, 3);
139 SCM_SET_CELL_OBJECT_1 (ret, a);
140 SCM_SET_CELL_OBJECT_2 (ret, b);
141
142 return ret;
143 }
144
145 SCM
scm_values_3(SCM a,SCM b,SCM c)146 scm_values_3 (SCM a, SCM b, SCM c)
147 {
148 SCM ret;
149
150 ret = scm_words ((3 << 8) | scm_tc7_values, 4);
151 SCM_SET_CELL_OBJECT_1 (ret, a);
152 SCM_SET_CELL_OBJECT_2 (ret, b);
153 SCM_SET_CELL_OBJECT_3 (ret, c);
154
155 return ret;
156 }
157
158 void
scm_init_values(void)159 scm_init_values (void)
160 {
161 scm_add_feature ("values");
162
163 #include "values.x"
164 }
165