Commit | Line | Data |
---|---|---|
dbb605f5 | 1 | /* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008 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 | ||
0f2d19dd JB |
30 | \f |
31 | ||
0f2d19dd JB |
32 | /* {Pairs} |
33 | */ | |
34 | ||
e81d98ec DH |
35 | #if (SCM_DEBUG_PAIR_ACCESSES == 1) |
36 | ||
ba1b2226 | 37 | #include "libguile/ports.h" |
e81d98ec DH |
38 | #include "libguile/strings.h" |
39 | ||
40 | void scm_error_pair_access (SCM non_pair) | |
41 | { | |
bab246f3 | 42 | static unsigned int running = 0; |
f32632e6 | 43 | SCM message = scm_from_locale_string ("Non-pair accessed with SCM_C[AD]R: `~S'\n"); |
bab246f3 DH |
44 | |
45 | if (!running) | |
46 | { | |
47 | running = 1; | |
48 | scm_simple_format (scm_current_error_port (), | |
1afff620 | 49 | message, scm_list_1 (non_pair)); |
bab246f3 DH |
50 | abort (); |
51 | } | |
e81d98ec DH |
52 | } |
53 | ||
54 | #endif | |
55 | ||
3b3b36dd | 56 | SCM_DEFINE (scm_cons, "cons", 2, 0, 0, |
4983cbe4 | 57 | (SCM x, SCM y), |
1e6808ea MG |
58 | "Return a newly allocated pair whose car is @var{x} and whose\n" |
59 | "cdr is @var{y}. The pair is guaranteed to be different (in the\n" | |
60 | "sense of @code{eq?}) from every previously existing object.") | |
1bbd0b84 | 61 | #define FUNC_NAME s_scm_cons |
0f2d19dd | 62 | { |
228a24ef | 63 | return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)); |
0f2d19dd | 64 | } |
1bbd0b84 | 65 | #undef FUNC_NAME |
0f2d19dd | 66 | |
1cc91f1b | 67 | |
0f2d19dd | 68 | SCM |
1bbd0b84 | 69 | scm_cons2 (SCM w, SCM x, SCM y) |
0f2d19dd | 70 | { |
16d4699b | 71 | return scm_cons (w, scm_cons (x, y)); |
0f2d19dd JB |
72 | } |
73 | ||
74 | ||
a1ec6916 | 75 | SCM_DEFINE (scm_pair_p, "pair?", 1, 0, 0, |
1bbd0b84 | 76 | (SCM x), |
1e6808ea MG |
77 | "Return @code{#t} if @var{x} is a pair; otherwise return\n" |
78 | "@code{#f}.") | |
1bbd0b84 | 79 | #define FUNC_NAME s_scm_pair_p |
0f2d19dd | 80 | { |
6fcc7d48 | 81 | return scm_from_bool (scm_is_pair (x)); |
0f2d19dd | 82 | } |
1bbd0b84 | 83 | #undef FUNC_NAME |
0f2d19dd | 84 | |
6fcc7d48 MV |
85 | SCM |
86 | scm_car (SCM pair) | |
87 | { | |
88 | if (!scm_is_pair (pair)) | |
89 | scm_wrong_type_arg_msg (NULL, 0, pair, "pair"); | |
90 | return SCM_CAR (pair); | |
91 | } | |
92 | ||
93 | SCM | |
94 | scm_cdr (SCM pair) | |
95 | { | |
96 | if (!scm_is_pair (pair)) | |
97 | scm_wrong_type_arg_msg (NULL, 0, pair, "pair"); | |
98 | return SCM_CDR (pair); | |
99 | } | |
100 | ||
101 | SCM | |
7dab4b37 | 102 | scm_i_chase_pairs (SCM tree, scm_t_uint32 pattern) |
6fcc7d48 MV |
103 | { |
104 | do | |
105 | { | |
106 | if (!scm_is_pair (tree)) | |
107 | scm_wrong_type_arg_msg (NULL, 0, tree, "pair"); | |
108 | tree = (pattern & 1) ? SCM_CAR (tree) : SCM_CDR (tree); | |
109 | pattern >>= 2; | |
110 | } | |
111 | while (pattern); | |
112 | return tree; | |
113 | } | |
4983cbe4 | 114 | |
a1ec6916 | 115 | SCM_DEFINE (scm_set_car_x, "set-car!", 2, 0, 0, |
1bbd0b84 | 116 | (SCM pair, SCM value), |
d7588e54 GB |
117 | "Stores @var{value} in the car field of @var{pair}. The value returned\n" |
118 | "by @code{set-car!} is unspecified.") | |
1bbd0b84 | 119 | #define FUNC_NAME s_scm_set_car_x |
0f2d19dd | 120 | { |
4983cbe4 | 121 | SCM_VALIDATE_CONS (1, pair); |
d65010b8 | 122 | SCM_SETCAR (pair, value); |
9b8721aa | 123 | return SCM_UNSPECIFIED; |
0f2d19dd | 124 | } |
1bbd0b84 | 125 | #undef FUNC_NAME |
0f2d19dd | 126 | |
4983cbe4 | 127 | |
a1ec6916 | 128 | SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0, |
1bbd0b84 | 129 | (SCM pair, SCM value), |
d7588e54 GB |
130 | "Stores @var{value} in the cdr field of @var{pair}. The value returned\n" |
131 | "by @code{set-cdr!} is unspecified.") | |
1bbd0b84 | 132 | #define FUNC_NAME s_scm_set_cdr_x |
0f2d19dd | 133 | { |
4983cbe4 | 134 | SCM_VALIDATE_CONS (1, pair); |
d65010b8 | 135 | SCM_SETCDR (pair, value); |
9b8721aa | 136 | return SCM_UNSPECIFIED; |
0f2d19dd | 137 | } |
1bbd0b84 | 138 | #undef FUNC_NAME |
0f2d19dd | 139 | |
0f2d19dd JB |
140 | \f |
141 | ||
14b18ed6 DH |
142 | /* Every cxr-pattern is made up of pairs of bits, starting with the two least |
143 | * significant bits. If in a pair of bits the least significant of the two | |
144 | * bits is 0, this means CDR, otherwise CAR. The most significant bits of the | |
145 | * two bits is only needed to indicate when cxr-ing is ready. This is the | |
146 | * case, when all remaining pairs of bits equal 00. */ | |
147 | ||
148 | typedef struct { | |
149 | const char *name; | |
150 | unsigned char pattern; | |
151 | } t_cxr; | |
152 | ||
153 | static const t_cxr cxrs[] = | |
0f2d19dd | 154 | { |
14b18ed6 DH |
155 | {"cdr", 0x02}, /* 00000010 */ |
156 | {"car", 0x03}, /* 00000011 */ | |
157 | {"cddr", 0x0a}, /* 00001010 */ | |
158 | {"cdar", 0x0b}, /* 00001011 */ | |
159 | {"cadr", 0x0e}, /* 00001110 */ | |
160 | {"caar", 0x0f}, /* 00001111 */ | |
161 | {"cdddr", 0x2a}, /* 00101010 */ | |
162 | {"cddar", 0x2b}, /* 00101011 */ | |
163 | {"cdadr", 0x2e}, /* 00101110 */ | |
164 | {"cdaar", 0x2f}, /* 00101111 */ | |
165 | {"caddr", 0x3a}, /* 00111010 */ | |
166 | {"cadar", 0x3b}, /* 00111011 */ | |
167 | {"caadr", 0x3e}, /* 00111110 */ | |
168 | {"caaar", 0x3f}, /* 00111111 */ | |
169 | {"cddddr", 0xaa}, /* 10101010 */ | |
170 | {"cdddar", 0xab}, /* 10101011 */ | |
171 | {"cddadr", 0xae}, /* 10101110 */ | |
172 | {"cddaar", 0xaf}, /* 10101111 */ | |
173 | {"cdaddr", 0xba}, /* 10111010 */ | |
174 | {"cdadar", 0xbb}, /* 10111011 */ | |
175 | {"cdaadr", 0xbe}, /* 10111110 */ | |
176 | {"cdaaar", 0xbf}, /* 10111111 */ | |
177 | {"cadddr", 0xea}, /* 11101010 */ | |
178 | {"caddar", 0xeb}, /* 11101011 */ | |
179 | {"cadadr", 0xee}, /* 11101110 */ | |
180 | {"cadaar", 0xef}, /* 11101111 */ | |
181 | {"caaddr", 0xfa}, /* 11111010 */ | |
182 | {"caadar", 0xfb}, /* 11111011 */ | |
183 | {"caaadr", 0xfe}, /* 11111110 */ | |
184 | {"caaaar", 0xff}, /* 11111111 */ | |
185 | {0, 0} | |
0f2d19dd JB |
186 | }; |
187 | ||
188 | \f | |
1cc91f1b | 189 | |
0f2d19dd JB |
190 | void |
191 | scm_init_pairs () | |
0f2d19dd | 192 | { |
e59bb516 DH |
193 | unsigned int subnr = 0; |
194 | ||
14b18ed6 DH |
195 | for (subnr = 0; cxrs[subnr].name; subnr++) |
196 | { | |
197 | SCM (*pattern) () = (SCM (*) ()) (scm_t_bits) cxrs[subnr].pattern; | |
198 | scm_c_define_subr (cxrs[subnr].name, scm_tc7_cxr, pattern); | |
199 | } | |
e59bb516 | 200 | |
a0599745 | 201 | #include "libguile/pairs.x" |
0f2d19dd JB |
202 | } |
203 | ||
89e00824 ML |
204 | |
205 | /* | |
206 | Local Variables: | |
207 | c-file-style: "gnu" | |
208 | End: | |
209 | */ |