Commit | Line | Data |
---|---|---|
c15defef | 1 | /* Copyright (C) 2000, 2001, 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc. |
ce212434 | 2 | * |
73be1d9e | 3 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
4 | * modify it under the terms of the GNU Lesser General Public License |
5 | * as published by the Free Software Foundation; either version 3 of | |
6 | * the License, or (at your option) any later version. | |
ce212434 | 7 | * |
53befeb7 NJ |
8 | * This library is distributed in the hope that it will be useful, but |
9 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | * Lesser General Public License for more details. | |
ce212434 | 12 | * |
73be1d9e MV |
13 | * You should have received a copy of the GNU Lesser General Public |
14 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
16 | * 02110-1301 USA | |
73be1d9e | 17 | */ |
ce212434 | 18 | |
dbb605f5 LC |
19 | #ifdef HAVE_CONFIG_H |
20 | # include <config.h> | |
21 | #endif | |
22 | ||
ce212434 GH |
23 | #include "libguile/_scm.h" |
24 | #include "libguile/eval.h" | |
25 | #include "libguile/feature.h" | |
26 | #include "libguile/gc.h" | |
27 | #include "libguile/numbers.h" | |
28 | #include "libguile/ports.h" | |
29 | #include "libguile/root.h" | |
30 | #include "libguile/strings.h" | |
31 | #include "libguile/struct.h" | |
32 | #include "libguile/validate.h" | |
33 | ||
34 | #include "libguile/values.h" | |
35 | ||
752af227 | 36 | SCM scm_values_vtable; |
ce212434 | 37 | |
a85c1f93 MW |
38 | /* OBJ must be a values object containing exactly two values. |
39 | scm_i_extract_values_2 puts those two values into *p1 and *p2. */ | |
40 | void | |
41 | scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2) | |
42 | { | |
43 | SCM values; | |
44 | ||
45 | SCM_ASSERT_TYPE (SCM_VALUESP (obj), obj, SCM_ARG1, | |
46 | "scm_i_extract_values_2", "values"); | |
47 | values = scm_struct_ref (obj, SCM_INUM0); | |
7017846b | 48 | if (scm_ilength (values) != 2) |
a85c1f93 MW |
49 | scm_wrong_type_arg_msg |
50 | ("scm_i_extract_values_2", SCM_ARG1, obj, | |
51 | "a values object containing exactly two values"); | |
52 | *p1 = SCM_CAR (values); | |
53 | *p2 = SCM_CADR (values); | |
54 | } | |
55 | ||
ce212434 GH |
56 | static SCM |
57 | print_values (SCM obj, SCM pwps) | |
58 | { | |
59 | SCM values = scm_struct_ref (obj, SCM_INUM0); | |
60 | SCM port = SCM_PORT_WITH_PS_PORT (pwps); | |
61 | scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps)); | |
62 | ||
0607ebbf | 63 | scm_puts_unlocked ("#<values ", port); |
9d47027e | 64 | scm_iprin1 (values, port, ps); |
0607ebbf | 65 | scm_puts_unlocked (">", port); |
9d47027e | 66 | |
ce212434 GH |
67 | return SCM_UNSPECIFIED; |
68 | } | |
69 | ||
e1c80e6b AW |
70 | size_t |
71 | scm_c_nvalues (SCM obj) | |
72 | { | |
73 | if (SCM_LIKELY (SCM_VALUESP (obj))) | |
74 | return scm_ilength (scm_struct_ref (obj, SCM_INUM0)); | |
75 | else | |
76 | return 1; | |
77 | } | |
78 | ||
1ceeca0a MW |
79 | SCM |
80 | scm_c_value_ref (SCM obj, size_t idx) | |
81 | { | |
82 | if (SCM_LIKELY (SCM_VALUESP (obj))) | |
83 | { | |
84 | SCM values = scm_struct_ref (obj, SCM_INUM0); | |
85 | size_t i = idx; | |
86 | while (SCM_LIKELY (scm_is_pair (values))) | |
87 | { | |
88 | if (i == 0) | |
89 | return SCM_CAR (values); | |
90 | values = SCM_CDR (values); | |
91 | i--; | |
92 | } | |
93 | } | |
94 | else if (idx == 0) | |
95 | return obj; | |
96 | ||
97 | scm_error (scm_out_of_range_key, | |
98 | "scm_c_value_ref", | |
99 | "Too few values in ~S to access index ~S", | |
44390164 AW |
100 | scm_list_2 (obj, scm_from_size_t (idx)), |
101 | scm_list_1 (scm_from_size_t (idx))); | |
1ceeca0a MW |
102 | } |
103 | ||
ce212434 GH |
104 | SCM_DEFINE (scm_values, "values", 0, 0, 1, |
105 | (SCM args), | |
106 | "Delivers all of its arguments to its continuation. Except for\n" | |
647e35e2 MG |
107 | "continuations created by the @code{call-with-values} procedure,\n" |
108 | "all continuations take exactly one value. The effect of\n" | |
109 | "passing no value or more than one value to continuations that\n" | |
110 | "were not created by @code{call-with-values} is unspecified.") | |
ce212434 GH |
111 | #define FUNC_NAME s_scm_values |
112 | { | |
c014a02e | 113 | long n; |
ce212434 GH |
114 | SCM result; |
115 | ||
116 | SCM_VALIDATE_LIST_COPYLEN (1, args, n); | |
117 | if (n == 1) | |
118 | result = SCM_CAR (args); | |
119 | else | |
c15defef | 120 | result = scm_c_make_struct (scm_values_vtable, 0, 1, SCM_UNPACK (args)); |
ce212434 GH |
121 | |
122 | return result; | |
123 | } | |
124 | #undef FUNC_NAME | |
125 | ||
c15defef AW |
126 | SCM |
127 | scm_c_values (SCM *base, size_t nvalues) | |
128 | { | |
129 | SCM ret, *walk; | |
130 | ||
131 | if (nvalues == 1) | |
132 | return *base; | |
133 | ||
134 | for (ret = SCM_EOL, walk = base + nvalues - 1; walk >= base; walk--) | |
135 | ret = scm_cons (*walk, ret); | |
136 | ||
137 | return scm_values (ret); | |
138 | } | |
139 | ||
ce212434 GH |
140 | void |
141 | scm_init_values (void) | |
142 | { | |
df9ca8d8 | 143 | SCM print = scm_c_define_gsubr ("%print-values", 2, 0, 0, print_values); |
ce212434 | 144 | |
b7bff2ba | 145 | scm_values_vtable = scm_make_vtable (scm_from_locale_string ("pr"), print); |
ce212434 GH |
146 | |
147 | scm_add_feature ("values"); | |
148 | ||
ce212434 | 149 | #include "libguile/values.x" |
ce212434 GH |
150 | } |
151 | ||
152 | /* | |
153 | Local Variables: | |
154 | c-file-style: "gnu" | |
155 | End: | |
156 | */ |