Commit | Line | Data |
---|---|---|
210c0325 | 1 | /* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008, 2009, 2011 Free Software Foundation, Inc. |
0f2d19dd | 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. | |
0f2d19dd | 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. | |
0f2d19dd | 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 | */ |
1bbd0b84 | 18 | |
1bbd0b84 | 19 | |
0f2d19dd | 20 | \f |
dbb605f5 LC |
21 | #ifdef HAVE_CONFIG_H |
22 | # include <config.h> | |
23 | #endif | |
4983cbe4 | 24 | |
a0599745 | 25 | #include "libguile/_scm.h" |
a0599745 | 26 | #include "libguile/validate.h" |
1bbd0b84 | 27 | |
4983cbe4 DH |
28 | #include "libguile/pairs.h" |
29 | ||
45f4cbdf MW |
30 | #include "verify.h" |
31 | ||
0f2d19dd JB |
32 | \f |
33 | ||
0f2d19dd JB |
34 | /* {Pairs} |
35 | */ | |
36 | ||
45f4cbdf MW |
37 | /* |
38 | * This compile-time test verifies the properties needed for the | |
39 | * efficient test macro scm_is_null_or_nil defined in pairs.h, | |
40 | * which is defined in terms of the SCM_MATCHES_BITS_IN_COMMON macro. | |
41 | * | |
42 | * See the comments preceeding the definitions of SCM_BOOL_F and | |
43 | * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information. | |
44 | */ | |
210c0325 AW |
45 | verify (SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \ |
46 | (SCM_ELISP_NIL_BITS, SCM_EOL_BITS)); | |
45f4cbdf MW |
47 | |
48 | ||
e81d98ec DH |
49 | #if (SCM_DEBUG_PAIR_ACCESSES == 1) |
50 | ||
ba1b2226 | 51 | #include "libguile/ports.h" |
e81d98ec DH |
52 | #include "libguile/strings.h" |
53 | ||
54 | void scm_error_pair_access (SCM non_pair) | |
55 | { | |
bab246f3 | 56 | static unsigned int running = 0; |
f32632e6 | 57 | SCM message = scm_from_locale_string ("Non-pair accessed with SCM_C[AD]R: `~S'\n"); |
bab246f3 DH |
58 | |
59 | if (!running) | |
60 | { | |
61 | running = 1; | |
62 | scm_simple_format (scm_current_error_port (), | |
1afff620 | 63 | message, scm_list_1 (non_pair)); |
bab246f3 DH |
64 | abort (); |
65 | } | |
e81d98ec DH |
66 | } |
67 | ||
68 | #endif | |
69 | ||
3b3b36dd | 70 | SCM_DEFINE (scm_cons, "cons", 2, 0, 0, |
4983cbe4 | 71 | (SCM x, SCM y), |
1e6808ea MG |
72 | "Return a newly allocated pair whose car is @var{x} and whose\n" |
73 | "cdr is @var{y}. The pair is guaranteed to be different (in the\n" | |
74 | "sense of @code{eq?}) from every previously existing object.") | |
1bbd0b84 | 75 | #define FUNC_NAME s_scm_cons |
0f2d19dd | 76 | { |
228a24ef | 77 | return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)); |
0f2d19dd | 78 | } |
1bbd0b84 | 79 | #undef FUNC_NAME |
0f2d19dd | 80 | |
1cc91f1b | 81 | |
0f2d19dd | 82 | SCM |
1bbd0b84 | 83 | scm_cons2 (SCM w, SCM x, SCM y) |
0f2d19dd | 84 | { |
16d4699b | 85 | return scm_cons (w, scm_cons (x, y)); |
0f2d19dd JB |
86 | } |
87 | ||
88 | ||
a1ec6916 | 89 | SCM_DEFINE (scm_pair_p, "pair?", 1, 0, 0, |
1bbd0b84 | 90 | (SCM x), |
1e6808ea MG |
91 | "Return @code{#t} if @var{x} is a pair; otherwise return\n" |
92 | "@code{#f}.") | |
1bbd0b84 | 93 | #define FUNC_NAME s_scm_pair_p |
0f2d19dd | 94 | { |
6fcc7d48 | 95 | return scm_from_bool (scm_is_pair (x)); |
0f2d19dd | 96 | } |
1bbd0b84 | 97 | #undef FUNC_NAME |
0f2d19dd | 98 | |
a1ec6916 | 99 | SCM_DEFINE (scm_set_car_x, "set-car!", 2, 0, 0, |
1bbd0b84 | 100 | (SCM pair, SCM value), |
d7588e54 GB |
101 | "Stores @var{value} in the car field of @var{pair}. The value returned\n" |
102 | "by @code{set-car!} is unspecified.") | |
1bbd0b84 | 103 | #define FUNC_NAME s_scm_set_car_x |
0f2d19dd | 104 | { |
4983cbe4 | 105 | SCM_VALIDATE_CONS (1, pair); |
d65010b8 | 106 | SCM_SETCAR (pair, value); |
9b8721aa | 107 | return SCM_UNSPECIFIED; |
0f2d19dd | 108 | } |
1bbd0b84 | 109 | #undef FUNC_NAME |
0f2d19dd | 110 | |
4983cbe4 | 111 | |
a1ec6916 | 112 | SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0, |
1bbd0b84 | 113 | (SCM pair, SCM value), |
d7588e54 GB |
114 | "Stores @var{value} in the cdr field of @var{pair}. The value returned\n" |
115 | "by @code{set-cdr!} is unspecified.") | |
1bbd0b84 | 116 | #define FUNC_NAME s_scm_set_cdr_x |
0f2d19dd | 117 | { |
4983cbe4 | 118 | SCM_VALIDATE_CONS (1, pair); |
d65010b8 | 119 | SCM_SETCDR (pair, value); |
9b8721aa | 120 | return SCM_UNSPECIFIED; |
0f2d19dd | 121 | } |
1bbd0b84 | 122 | #undef FUNC_NAME |
0f2d19dd | 123 | |
0f2d19dd JB |
124 | \f |
125 | ||
14b18ed6 DH |
126 | /* Every cxr-pattern is made up of pairs of bits, starting with the two least |
127 | * significant bits. If in a pair of bits the least significant of the two | |
128 | * bits is 0, this means CDR, otherwise CAR. The most significant bits of the | |
129 | * two bits is only needed to indicate when cxr-ing is ready. This is the | |
130 | * case, when all remaining pairs of bits equal 00. */ | |
131 | ||
f36878ba AW |
132 | /* The compiler should unroll this. */ |
133 | #define CHASE_PAIRS(tree, FUNC_NAME, pattern) \ | |
134 | scm_t_uint32 pattern_var = pattern; \ | |
135 | do \ | |
136 | { \ | |
137 | if (!scm_is_pair (tree)) \ | |
138 | scm_wrong_type_arg_msg (FUNC_NAME, 0, tree, "pair"); \ | |
139 | tree = (pattern_var & 1) ? SCM_CAR (tree) : SCM_CDR (tree); \ | |
140 | pattern_var >>= 2; \ | |
141 | } \ | |
142 | while (pattern_var); \ | |
143 | return tree | |
144 | ||
145 | ||
146 | SCM_DEFINE (scm_cdr, "cdr", 1, 0, 0, (SCM x), "") | |
147 | { | |
148 | CHASE_PAIRS (x, "cdr", 0x02); /* 00000010 */ | |
149 | } | |
150 | SCM_DEFINE (scm_car, "car", 1, 0, 0, (SCM x), "") | |
151 | { | |
152 | CHASE_PAIRS (x, "car", 0x03); /* 00000011 */ | |
153 | } | |
154 | SCM_DEFINE (scm_cddr, "cddr", 1, 0, 0, (SCM x), "") | |
155 | { | |
156 | CHASE_PAIRS (x, "cddr", 0x0a); /* 00001010 */ | |
157 | } | |
158 | SCM_DEFINE (scm_cdar, "cdar", 1, 0, 0, (SCM x), "") | |
159 | { | |
160 | CHASE_PAIRS (x, "cdar", 0x0b); /* 00001011 */ | |
161 | } | |
162 | SCM_DEFINE (scm_cadr, "cadr", 1, 0, 0, (SCM x), "") | |
163 | { | |
164 | CHASE_PAIRS (x, "cadr", 0x0e); /* 00001110 */ | |
165 | } | |
166 | SCM_DEFINE (scm_caar, "caar", 1, 0, 0, (SCM x), "") | |
167 | { | |
168 | CHASE_PAIRS (x, "caar", 0x0f); /* 00001111 */ | |
169 | } | |
170 | SCM_DEFINE (scm_cdddr, "cdddr", 1, 0, 0, (SCM x), "") | |
171 | { | |
172 | CHASE_PAIRS (x, "cdddr", 0x2a); /* 00101010 */ | |
173 | } | |
174 | SCM_DEFINE (scm_cddar, "cddar", 1, 0, 0, (SCM x), "") | |
175 | { | |
176 | CHASE_PAIRS (x, "cddar", 0x2b); /* 00101011 */ | |
177 | } | |
178 | SCM_DEFINE (scm_cdadr, "cdadr", 1, 0, 0, (SCM x), "") | |
179 | { | |
180 | CHASE_PAIRS (x, "cdadr", 0x2e); /* 00101110 */ | |
181 | } | |
182 | SCM_DEFINE (scm_cdaar, "cdaar", 1, 0, 0, (SCM x), "") | |
183 | { | |
184 | CHASE_PAIRS (x, "cdaar", 0x2f); /* 00101111 */ | |
185 | } | |
186 | SCM_DEFINE (scm_caddr, "caddr", 1, 0, 0, (SCM x), "") | |
187 | { | |
188 | CHASE_PAIRS (x, "caddr", 0x3a); /* 00111010 */ | |
189 | } | |
190 | SCM_DEFINE (scm_cadar, "cadar", 1, 0, 0, (SCM x), "") | |
191 | { | |
192 | CHASE_PAIRS (x, "cadar", 0x3b); /* 00111011 */ | |
193 | } | |
194 | SCM_DEFINE (scm_caadr, "caadr", 1, 0, 0, (SCM x), "") | |
195 | { | |
196 | CHASE_PAIRS (x, "caadr", 0x3e); /* 00111110 */ | |
197 | } | |
198 | SCM_DEFINE (scm_caaar, "caaar", 1, 0, 0, (SCM x), "") | |
199 | { | |
200 | CHASE_PAIRS (x, "caaar", 0x3f); /* 00111111 */ | |
201 | } | |
202 | SCM_DEFINE (scm_cddddr, "cddddr", 1, 0, 0, (SCM x), "") | |
203 | { | |
204 | CHASE_PAIRS (x, "cddddr", 0xaa); /* 10101010 */ | |
205 | } | |
206 | SCM_DEFINE (scm_cdddar, "cdddar", 1, 0, 0, (SCM x), "") | |
207 | { | |
208 | CHASE_PAIRS (x, "cdddar", 0xab); /* 10101011 */ | |
209 | } | |
210 | SCM_DEFINE (scm_cddadr, "cddadr", 1, 0, 0, (SCM x), "") | |
211 | { | |
212 | CHASE_PAIRS (x, "cddadr", 0xae); /* 10101110 */ | |
213 | } | |
214 | SCM_DEFINE (scm_cddaar, "cddaar", 1, 0, 0, (SCM x), "") | |
215 | { | |
216 | CHASE_PAIRS (x, "cddaar", 0xaf); /* 10101111 */ | |
217 | } | |
218 | SCM_DEFINE (scm_cdaddr, "cdaddr", 1, 0, 0, (SCM x), "") | |
219 | { | |
220 | CHASE_PAIRS (x, "cdaddr", 0xba); /* 10111010 */ | |
221 | } | |
222 | SCM_DEFINE (scm_cdadar, "cdadar", 1, 0, 0, (SCM x), "") | |
223 | { | |
224 | CHASE_PAIRS (x, "cdadar", 0xbb); /* 10111011 */ | |
225 | } | |
226 | SCM_DEFINE (scm_cdaadr, "cdaadr", 1, 0, 0, (SCM x), "") | |
227 | { | |
228 | CHASE_PAIRS (x, "cdaadr", 0xbe); /* 10111110 */ | |
229 | } | |
230 | SCM_DEFINE (scm_cdaaar, "cdaaar", 1, 0, 0, (SCM x), "") | |
231 | { | |
232 | CHASE_PAIRS (x, "cdaaar", 0xbf); /* 10111111 */ | |
233 | } | |
234 | SCM_DEFINE (scm_cadddr, "cadddr", 1, 0, 0, (SCM x), "") | |
235 | { | |
236 | CHASE_PAIRS (x, "cadddr", 0xea); /* 11101010 */ | |
237 | } | |
238 | SCM_DEFINE (scm_caddar, "caddar", 1, 0, 0, (SCM x), "") | |
239 | { | |
240 | CHASE_PAIRS (x, "caddar", 0xeb); /* 11101011 */ | |
241 | } | |
242 | SCM_DEFINE (scm_cadadr, "cadadr", 1, 0, 0, (SCM x), "") | |
243 | { | |
244 | CHASE_PAIRS (x, "cadadr", 0xee); /* 11101110 */ | |
245 | } | |
246 | SCM_DEFINE (scm_cadaar, "cadaar", 1, 0, 0, (SCM x), "") | |
247 | { | |
248 | CHASE_PAIRS (x, "cadaar", 0xef); /* 11101111 */ | |
249 | } | |
250 | SCM_DEFINE (scm_caaddr, "caaddr", 1, 0, 0, (SCM x), "") | |
251 | { | |
252 | CHASE_PAIRS (x, "caaddr", 0xfa); /* 11111010 */ | |
253 | } | |
254 | SCM_DEFINE (scm_caadar, "caadar", 1, 0, 0, (SCM x), "") | |
255 | { | |
256 | CHASE_PAIRS (x, "caadar", 0xfb); /* 11111011 */ | |
257 | } | |
258 | SCM_DEFINE (scm_caaadr, "caaadr", 1, 0, 0, (SCM x), "") | |
259 | { | |
260 | CHASE_PAIRS (x, "caaadr", 0xfe); /* 11111110 */ | |
261 | } | |
262 | SCM_DEFINE (scm_caaaar, "caaaar", 1, 0, 0, (SCM x), "") | |
263 | { | |
264 | CHASE_PAIRS (x, "caaaar", 0xff); /* 11111111 */ | |
265 | } | |
0f2d19dd JB |
266 | |
267 | \f | |
1cc91f1b | 268 | |
0f2d19dd JB |
269 | void |
270 | scm_init_pairs () | |
0f2d19dd | 271 | { |
a0599745 | 272 | #include "libguile/pairs.x" |
0f2d19dd JB |
273 | } |
274 | ||
89e00824 ML |
275 | |
276 | /* | |
277 | Local Variables: | |
278 | c-file-style: "gnu" | |
279 | End: | |
280 | */ |