libguile/pairs.c

   1 /* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008, 2009,
   2  *   2011, 2012, 2013 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22 #ifdef HAVE_CONFIG_H
  23 # include <config.h>
  24 #endif
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/validate.h"
  28
  29 #include "libguile/pairs.h"
  30
  31 #include "verify.h"
  32
  33 \f
  34
  35 /* {Pairs}
  36  */
  37
  38 /*
  39  * This compile-time test verifies the properties needed for the
  40  * efficient test macro scm_is_null_or_nil defined in pairs.h,
  41  * which is defined in terms of the SCM_MATCHES_BITS_IN_COMMON macro.
  42  *
  43  * See the comments preceeding the definitions of SCM_BOOL_F and
  44  * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
  45  */
  46 verify (SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION             \
  47         (SCM_ELISP_NIL_BITS, SCM_EOL_BITS));
  48
  49
  50 #if (SCM_DEBUG_PAIR_ACCESSES == 1)
  51
  52 #include "libguile/ports.h"
  53 #include "libguile/strings.h"
  54
  55 void scm_error_pair_access (SCM non_pair)
  56 {
  57   static unsigned int running = 0;
  58   SCM message = scm_from_locale_string ("Non-pair accessed with SCM_C[AD]R: `~S'\n");
  59
  60   if (!running)
  61     {
  62       running = 1;
  63       scm_simple_format (scm_current_error_port (),
  64                          message, scm_list_1 (non_pair));
  65       abort ();
  66     }
  67 }
  68
  69 #endif
  70
  71 SCM
  72 scm_cons2 (SCM w, SCM x, SCM y)
  73 {
  74   return scm_cons (w, scm_cons (x, y));
  75 }
  76
  77
  78 SCM_DEFINE (scm_pair_p, "pair?", 1, 0, 0,
  79             (SCM x),
  80             "Return @code{#t} if @var{x} is a pair; otherwise return\n"
  81             "@code{#f}.")
  82 #define FUNC_NAME s_scm_pair_p
  83 {
  84   return scm_from_bool (scm_is_pair (x));
  85 }
  86 #undef FUNC_NAME
  87
  88 SCM_DEFINE (scm_set_car_x, "set-car!", 2, 0, 0,
  89             (SCM pair, SCM value),
  90             "Stores @var{value} in the car field of @var{pair}.  The value returned\n"
  91             "by @code{set-car!} is unspecified.")
  92 #define FUNC_NAME s_scm_set_car_x
  93 {
  94   SCM_VALIDATE_CONS (1, pair);
  95   SCM_SETCAR (pair, value);
  96   return SCM_UNSPECIFIED;
  97 }
  98 #undef FUNC_NAME
  99
 100
 101 SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0,
 102             (SCM pair, SCM value),
 103             "Stores @var{value} in the cdr field of @var{pair}.  The value returned\n"
 104             "by @code{set-cdr!} is unspecified.")
 105 #define FUNC_NAME s_scm_set_cdr_x
 106 {
 107   SCM_VALIDATE_CONS (1, pair);
 108   SCM_SETCDR (pair, value);
 109   return SCM_UNSPECIFIED;
 110 }
 111 #undef FUNC_NAME
 112
 113 \f
 114
 115 /* Every cxr-pattern is made up of pairs of bits, starting with the two least
 116  * significant bits.  If in a pair of bits the least significant of the two
 117  * bits is 0, this means CDR, otherwise CAR.  The most significant bits of the
 118  * two bits is only needed to indicate when cxr-ing is ready.  This is the
 119  * case, when all remaining pairs of bits equal 00.  */
 120
 121 /* The compiler should unroll this. */
 122 #define CHASE_PAIRS(tree, FUNC_NAME, pattern)                           \
 123   scm_t_uint32 pattern_var = pattern;                                   \
 124   do                                                                    \
 125     {                                                                   \
 126       if (!scm_is_pair (tree))                                          \
 127         scm_wrong_type_arg_msg (FUNC_NAME, 0, tree, "pair");            \
 128       tree = (pattern_var & 1) ? SCM_CAR (tree) : SCM_CDR (tree);       \
 129       pattern_var >>= 2;                                                \
 130     }                                                                   \
 131   while (pattern_var);                                                  \
 132   return tree
 133
 134
 135 SCM_DEFINE (scm_cddr, "cddr", 1, 0, 0, (SCM x), "")
 136 #define FUNC_NAME s_scm_cddr
 137 {
 138   CHASE_PAIRS (x, "cddr", 0x0a); /* 00001010 */
 139 }
 140 #undef FUNC_NAME
 141
 142 SCM_DEFINE (scm_cdar, "cdar", 1, 0, 0, (SCM x), "")
 143 #define FUNC_NAME s_scm_cdar
 144 {
 145   CHASE_PAIRS (x, "cdar", 0x0b); /* 00001011 */
 146 }
 147 #undef FUNC_NAME
 148
 149 SCM_DEFINE (scm_cadr, "cadr", 1, 0, 0, (SCM x), "")
 150 #define FUNC_NAME s_scm_cadr
 151 {
 152   CHASE_PAIRS (x, "cadr", 0x0e); /* 00001110 */
 153 }
 154 #undef FUNC_NAME
 155
 156 SCM_DEFINE (scm_caar, "caar", 1, 0, 0, (SCM x), "")
 157 #define FUNC_NAME s_scm_caar
 158 {
 159   CHASE_PAIRS (x, "caar", 0x0f); /* 00001111 */
 160 }
 161 #undef FUNC_NAME
 162
 163 SCM_DEFINE (scm_cdddr, "cdddr", 1, 0, 0, (SCM x), "")
 164 #define FUNC_NAME s_scm_cdddr
 165 {
 166   CHASE_PAIRS (x, "cdddr", 0x2a); /* 00101010 */
 167 }
 168 #undef FUNC_NAME
 169
 170 SCM_DEFINE (scm_cddar, "cddar", 1, 0, 0, (SCM x), "")
 171 #define FUNC_NAME s_scm_cddar
 172 {
 173   CHASE_PAIRS (x, "cddar", 0x2b); /* 00101011 */
 174 }
 175 #undef FUNC_NAME
 176
 177 SCM_DEFINE (scm_cdadr, "cdadr", 1, 0, 0, (SCM x), "")
 178 #define FUNC_NAME s_scm_cdadr
 179 {
 180   CHASE_PAIRS (x, "cdadr", 0x2e); /* 00101110 */
 181 }
 182 #undef FUNC_NAME
 183
 184 SCM_DEFINE (scm_cdaar, "cdaar", 1, 0, 0, (SCM x), "")
 185 #define FUNC_NAME s_scm_cdaar
 186 {
 187   CHASE_PAIRS (x, "cdaar", 0x2f); /* 00101111 */
 188 }
 189 #undef FUNC_NAME
 190
 191 SCM_DEFINE (scm_caddr, "caddr", 1, 0, 0, (SCM x), "")
 192 #define FUNC_NAME s_scm_caddr
 193 {
 194   CHASE_PAIRS (x, "caddr", 0x3a); /* 00111010 */
 195 }
 196 #undef FUNC_NAME
 197
 198 SCM_DEFINE (scm_cadar, "cadar", 1, 0, 0, (SCM x), "")
 199 #define FUNC_NAME s_scm_cadar
 200 {
 201   CHASE_PAIRS (x, "cadar", 0x3b); /* 00111011 */
 202 }
 203 #undef FUNC_NAME
 204
 205 SCM_DEFINE (scm_caadr, "caadr", 1, 0, 0, (SCM x), "")
 206 #define FUNC_NAME s_scm_caadr
 207 {
 208   CHASE_PAIRS (x, "caadr", 0x3e); /* 00111110 */
 209 }
 210 #undef FUNC_NAME
 211
 212 SCM_DEFINE (scm_caaar, "caaar", 1, 0, 0, (SCM x), "")
 213 #define FUNC_NAME s_scm_caaar
 214 {
 215   CHASE_PAIRS (x, "caaar", 0x3f); /* 00111111 */
 216 }
 217 #undef FUNC_NAME
 218
 219 SCM_DEFINE (scm_cddddr, "cddddr", 1, 0, 0, (SCM x), "")
 220 #define FUNC_NAME s_scm_cddddr
 221 {
 222   CHASE_PAIRS (x, "cddddr", 0xaa); /* 10101010 */
 223 }
 224 #undef FUNC_NAME
 225
 226 SCM_DEFINE (scm_cdddar, "cdddar", 1, 0, 0, (SCM x), "")
 227 #define FUNC_NAME s_scm_cdddar
 228 {
 229   CHASE_PAIRS (x, "cdddar", 0xab); /* 10101011 */
 230 }
 231 #undef FUNC_NAME
 232
 233 SCM_DEFINE (scm_cddadr, "cddadr", 1, 0, 0, (SCM x), "")
 234 #define FUNC_NAME s_scm_cddadr
 235 {
 236   CHASE_PAIRS (x, "cddadr", 0xae); /* 10101110 */
 237 }
 238 #undef FUNC_NAME
 239
 240 SCM_DEFINE (scm_cddaar, "cddaar", 1, 0, 0, (SCM x), "")
 241 #define FUNC_NAME s_scm_cddaar
 242 {
 243   CHASE_PAIRS (x, "cddaar", 0xaf); /* 10101111 */
 244 }
 245 #undef FUNC_NAME
 246
 247 SCM_DEFINE (scm_cdaddr, "cdaddr", 1, 0, 0, (SCM x), "")
 248 #define FUNC_NAME s_scm_cdaddr
 249 {
 250   CHASE_PAIRS (x, "cdaddr", 0xba); /* 10111010 */
 251 }
 252 #undef FUNC_NAME
 253
 254 SCM_DEFINE (scm_cdadar, "cdadar", 1, 0, 0, (SCM x), "")
 255 #define FUNC_NAME s_scm_cdadar
 256 {
 257   CHASE_PAIRS (x, "cdadar", 0xbb); /* 10111011 */
 258 }
 259 #undef FUNC_NAME
 260
 261 SCM_DEFINE (scm_cdaadr, "cdaadr", 1, 0, 0, (SCM x), "")
 262 #define FUNC_NAME s_scm_cdaadr
 263 {
 264   CHASE_PAIRS (x, "cdaadr", 0xbe); /* 10111110 */
 265 }
 266 #undef FUNC_NAME
 267
 268 SCM_DEFINE (scm_cdaaar, "cdaaar", 1, 0, 0, (SCM x), "")
 269 #define FUNC_NAME s_scm_cdaaar
 270 {
 271   CHASE_PAIRS (x, "cdaaar", 0xbf); /* 10111111 */
 272 }
 273 #undef FUNC_NAME
 274
 275 SCM_DEFINE (scm_cadddr, "cadddr", 1, 0, 0, (SCM x), "")
 276 #define FUNC_NAME s_scm_cadddr
 277 {
 278   CHASE_PAIRS (x, "cadddr", 0xea); /* 11101010 */
 279 }
 280 #undef FUNC_NAME
 281
 282 SCM_DEFINE (scm_caddar, "caddar", 1, 0, 0, (SCM x), "")
 283 #define FUNC_NAME s_scm_caddar
 284 {
 285   CHASE_PAIRS (x, "caddar", 0xeb); /* 11101011 */
 286 }
 287 #undef FUNC_NAME
 288
 289 SCM_DEFINE (scm_cadadr, "cadadr", 1, 0, 0, (SCM x), "")
 290 #define FUNC_NAME s_scm_cadadr
 291 {
 292   CHASE_PAIRS (x, "cadadr", 0xee); /* 11101110 */
 293 }
 294 #undef FUNC_NAME
 295
 296 SCM_DEFINE (scm_cadaar, "cadaar", 1, 0, 0, (SCM x), "")
 297 #define FUNC_NAME s_scm_cadaar
 298 {
 299   CHASE_PAIRS (x, "cadaar", 0xef); /* 11101111 */
 300 }
 301 #undef FUNC_NAME
 302
 303 SCM_DEFINE (scm_caaddr, "caaddr", 1, 0, 0, (SCM x), "")
 304 #define FUNC_NAME s_scm_caaddr
 305 {
 306   CHASE_PAIRS (x, "caaddr", 0xfa); /* 11111010 */
 307 }
 308 #undef FUNC_NAME
 309
 310 SCM_DEFINE (scm_caadar, "caadar", 1, 0, 0, (SCM x), "")
 311 #define FUNC_NAME s_scm_caadar
 312 {
 313   CHASE_PAIRS (x, "caadar", 0xfb); /* 11111011 */
 314 }
 315 #undef FUNC_NAME
 316
 317 SCM_DEFINE (scm_caaadr, "caaadr", 1, 0, 0, (SCM x), "")
 318 #define FUNC_NAME s_scm_caaadr
 319 {
 320   CHASE_PAIRS (x, "caaadr", 0xfe); /* 11111110 */
 321 }
 322 #undef FUNC_NAME
 323
 324 SCM_DEFINE (scm_caaaar, "caaaar", 1, 0, 0, (SCM x), "")
 325 #define FUNC_NAME s_scm_caaaar
 326 {
 327   CHASE_PAIRS (x, "caaaar", 0xff); /* 11111111 */
 328 }
 329 #undef FUNC_NAME
 330
 331
 332 \f
 333
 334 void
 335 scm_init_pairs ()
 336 {
 337 #include "libguile/pairs.x"
 338   scm_c_define_gsubr ("cons", 2, 0, 0, scm_cons);
 339   scm_c_define_gsubr ("car", 1, 0, 0, scm_car);
 340   scm_c_define_gsubr ("cdr", 1, 0, 0, scm_cdr);
 341 }
 342
 343
 344 /*
 345   Local Variables:
 346   c-file-style: "gnu"
 347   End:
 348 */