libguile/pairs.c

   1 /* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008, 2009,
   2  *   2011, 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_DEFINE (scm_cons, "cons", 2, 0, 0,
  72             (SCM x, SCM y),
  73             "Return a newly allocated pair whose car is @var{x} and whose\n"
  74             "cdr is @var{y}.  The pair is guaranteed to be different (in the\n"
  75             "sense of @code{eq?}) from every previously existing object.")
  76 #define FUNC_NAME s_scm_cons
  77 {
  78   return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y));
  79 }
  80 #undef FUNC_NAME
  81
  82
  83 SCM
  84 scm_cons2 (SCM w, SCM x, SCM y)
  85 {
  86   return scm_cons (w, scm_cons (x, y));
  87 }
  88
  89
  90 SCM_DEFINE (scm_pair_p, "pair?", 1, 0, 0,
  91             (SCM x),
  92             "Return @code{#t} if @var{x} is a pair; otherwise return\n"
  93             "@code{#f}.")
  94 #define FUNC_NAME s_scm_pair_p
  95 {
  96   return scm_from_bool (scm_is_pair (x));
  97 }
  98 #undef FUNC_NAME
  99
 100 SCM_DEFINE (scm_set_car_x, "set-car!", 2, 0, 0,
 101             (SCM pair, SCM value),
 102             "Stores @var{value} in the car field of @var{pair}.  The value returned\n"
 103             "by @code{set-car!} is unspecified.")
 104 #define FUNC_NAME s_scm_set_car_x
 105 {
 106   SCM_VALIDATE_CONS (1, pair);
 107   SCM_SETCAR (pair, value);
 108   return SCM_UNSPECIFIED;
 109 }
 110 #undef FUNC_NAME
 111
 112
 113 SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0,
 114             (SCM pair, SCM value),
 115             "Stores @var{value} in the cdr field of @var{pair}.  The value returned\n"
 116             "by @code{set-cdr!} is unspecified.")
 117 #define FUNC_NAME s_scm_set_cdr_x
 118 {
 119   SCM_VALIDATE_CONS (1, pair);
 120   SCM_SETCDR (pair, value);
 121   return SCM_UNSPECIFIED;
 122 }
 123 #undef FUNC_NAME
 124
 125 \f
 126
 127 /* Every cxr-pattern is made up of pairs of bits, starting with the two least
 128  * significant bits.  If in a pair of bits the least significant of the two
 129  * bits is 0, this means CDR, otherwise CAR.  The most significant bits of the
 130  * two bits is only needed to indicate when cxr-ing is ready.  This is the
 131  * case, when all remaining pairs of bits equal 00.  */
 132
 133 /* The compiler should unroll this. */
 134 #define CHASE_PAIRS(tree, FUNC_NAME, pattern)                           \
 135   scm_t_uint32 pattern_var = pattern;                                   \
 136   do                                                                    \
 137     {                                                                   \
 138       if (!scm_is_pair (tree))                                          \
 139         scm_wrong_type_arg_msg (FUNC_NAME, 0, tree, "pair");            \
 140       tree = (pattern_var & 1) ? SCM_CAR (tree) : SCM_CDR (tree);       \
 141       pattern_var >>= 2;                                                \
 142     }                                                                   \
 143   while (pattern_var);                                                  \
 144   return tree
 145
 146
 147 SCM_DEFINE (scm_cdr, "cdr", 1, 0, 0, (SCM x), "")
 148 #define FUNC_NAME s_scm_cdr
 149 {
 150   CHASE_PAIRS (x, "cdr", 0x02); /* 00000010 */
 151 }
 152 #undef FUNC_NAME
 153
 154 SCM_DEFINE (scm_car, "car", 1, 0, 0, (SCM x), "")
 155 #define FUNC_NAME s_scm_car
 156 {
 157   CHASE_PAIRS (x, "car", 0x03); /* 00000011 */
 158 }
 159 #undef FUNC_NAME
 160
 161 SCM_DEFINE (scm_cddr, "cddr", 1, 0, 0, (SCM x), "")
 162 #define FUNC_NAME s_scm_cddr
 163 {
 164   CHASE_PAIRS (x, "cddr", 0x0a); /* 00001010 */
 165 }
 166 #undef FUNC_NAME
 167
 168 SCM_DEFINE (scm_cdar, "cdar", 1, 0, 0, (SCM x), "")
 169 #define FUNC_NAME s_scm_cdar
 170 {
 171   CHASE_PAIRS (x, "cdar", 0x0b); /* 00001011 */
 172 }
 173 #undef FUNC_NAME
 174
 175 SCM_DEFINE (scm_cadr, "cadr", 1, 0, 0, (SCM x), "")
 176 #define FUNC_NAME s_scm_cadr
 177 {
 178   CHASE_PAIRS (x, "cadr", 0x0e); /* 00001110 */
 179 }
 180 #undef FUNC_NAME
 181
 182 SCM_DEFINE (scm_caar, "caar", 1, 0, 0, (SCM x), "")
 183 #define FUNC_NAME s_scm_caar
 184 {
 185   CHASE_PAIRS (x, "caar", 0x0f); /* 00001111 */
 186 }
 187 #undef FUNC_NAME
 188
 189 SCM_DEFINE (scm_cdddr, "cdddr", 1, 0, 0, (SCM x), "")
 190 #define FUNC_NAME s_scm_cdddr
 191 {
 192   CHASE_PAIRS (x, "cdddr", 0x2a); /* 00101010 */
 193 }
 194 #undef FUNC_NAME
 195
 196 SCM_DEFINE (scm_cddar, "cddar", 1, 0, 0, (SCM x), "")
 197 #define FUNC_NAME s_scm_cddar
 198 {
 199   CHASE_PAIRS (x, "cddar", 0x2b); /* 00101011 */
 200 }
 201 #undef FUNC_NAME
 202
 203 SCM_DEFINE (scm_cdadr, "cdadr", 1, 0, 0, (SCM x), "")
 204 #define FUNC_NAME s_scm_cdadr
 205 {
 206   CHASE_PAIRS (x, "cdadr", 0x2e); /* 00101110 */
 207 }
 208 #undef FUNC_NAME
 209
 210 SCM_DEFINE (scm_cdaar, "cdaar", 1, 0, 0, (SCM x), "")
 211 #define FUNC_NAME s_scm_cdaar
 212 {
 213   CHASE_PAIRS (x, "cdaar", 0x2f); /* 00101111 */
 214 }
 215 #undef FUNC_NAME
 216
 217 SCM_DEFINE (scm_caddr, "caddr", 1, 0, 0, (SCM x), "")
 218 #define FUNC_NAME s_scm_caddr
 219 {
 220   CHASE_PAIRS (x, "caddr", 0x3a); /* 00111010 */
 221 }
 222 #undef FUNC_NAME
 223
 224 SCM_DEFINE (scm_cadar, "cadar", 1, 0, 0, (SCM x), "")
 225 #define FUNC_NAME s_scm_cadar
 226 {
 227   CHASE_PAIRS (x, "cadar", 0x3b); /* 00111011 */
 228 }
 229 #undef FUNC_NAME
 230
 231 SCM_DEFINE (scm_caadr, "caadr", 1, 0, 0, (SCM x), "")
 232 #define FUNC_NAME s_scm_caadr
 233 {
 234   CHASE_PAIRS (x, "caadr", 0x3e); /* 00111110 */
 235 }
 236 #undef FUNC_NAME
 237
 238 SCM_DEFINE (scm_caaar, "caaar", 1, 0, 0, (SCM x), "")
 239 #define FUNC_NAME s_scm_caaar
 240 {
 241   CHASE_PAIRS (x, "caaar", 0x3f); /* 00111111 */
 242 }
 243 #undef FUNC_NAME
 244
 245 SCM_DEFINE (scm_cddddr, "cddddr", 1, 0, 0, (SCM x), "")
 246 #define FUNC_NAME s_scm_cddddr
 247 {
 248   CHASE_PAIRS (x, "cddddr", 0xaa); /* 10101010 */
 249 }
 250 #undef FUNC_NAME
 251
 252 SCM_DEFINE (scm_cdddar, "cdddar", 1, 0, 0, (SCM x), "")
 253 #define FUNC_NAME s_scm_cdddar
 254 {
 255   CHASE_PAIRS (x, "cdddar", 0xab); /* 10101011 */
 256 }
 257 #undef FUNC_NAME
 258
 259 SCM_DEFINE (scm_cddadr, "cddadr", 1, 0, 0, (SCM x), "")
 260 #define FUNC_NAME s_scm_cddadr
 261 {
 262   CHASE_PAIRS (x, "cddadr", 0xae); /* 10101110 */
 263 }
 264 #undef FUNC_NAME
 265
 266 SCM_DEFINE (scm_cddaar, "cddaar", 1, 0, 0, (SCM x), "")
 267 #define FUNC_NAME s_scm_cddaar
 268 {
 269   CHASE_PAIRS (x, "cddaar", 0xaf); /* 10101111 */
 270 }
 271 #undef FUNC_NAME
 272
 273 SCM_DEFINE (scm_cdaddr, "cdaddr", 1, 0, 0, (SCM x), "")
 274 #define FUNC_NAME s_scm_cdaddr
 275 {
 276   CHASE_PAIRS (x, "cdaddr", 0xba); /* 10111010 */
 277 }
 278 #undef FUNC_NAME
 279
 280 SCM_DEFINE (scm_cdadar, "cdadar", 1, 0, 0, (SCM x), "")
 281 #define FUNC_NAME s_scm_cdadar
 282 {
 283   CHASE_PAIRS (x, "cdadar", 0xbb); /* 10111011 */
 284 }
 285 #undef FUNC_NAME
 286
 287 SCM_DEFINE (scm_cdaadr, "cdaadr", 1, 0, 0, (SCM x), "")
 288 #define FUNC_NAME s_scm_cdaadr
 289 {
 290   CHASE_PAIRS (x, "cdaadr", 0xbe); /* 10111110 */
 291 }
 292 #undef FUNC_NAME
 293
 294 SCM_DEFINE (scm_cdaaar, "cdaaar", 1, 0, 0, (SCM x), "")
 295 #define FUNC_NAME s_scm_cdaaar
 296 {
 297   CHASE_PAIRS (x, "cdaaar", 0xbf); /* 10111111 */
 298 }
 299 #undef FUNC_NAME
 300
 301 SCM_DEFINE (scm_cadddr, "cadddr", 1, 0, 0, (SCM x), "")
 302 #define FUNC_NAME s_scm_cadddr
 303 {
 304   CHASE_PAIRS (x, "cadddr", 0xea); /* 11101010 */
 305 }
 306 #undef FUNC_NAME
 307
 308 SCM_DEFINE (scm_caddar, "caddar", 1, 0, 0, (SCM x), "")
 309 #define FUNC_NAME s_scm_caddar
 310 {
 311   CHASE_PAIRS (x, "caddar", 0xeb); /* 11101011 */
 312 }
 313 #undef FUNC_NAME
 314
 315 SCM_DEFINE (scm_cadadr, "cadadr", 1, 0, 0, (SCM x), "")
 316 #define FUNC_NAME s_scm_cadadr
 317 {
 318   CHASE_PAIRS (x, "cadadr", 0xee); /* 11101110 */
 319 }
 320 #undef FUNC_NAME
 321
 322 SCM_DEFINE (scm_cadaar, "cadaar", 1, 0, 0, (SCM x), "")
 323 #define FUNC_NAME s_scm_cadaar
 324 {
 325   CHASE_PAIRS (x, "cadaar", 0xef); /* 11101111 */
 326 }
 327 #undef FUNC_NAME
 328
 329 SCM_DEFINE (scm_caaddr, "caaddr", 1, 0, 0, (SCM x), "")
 330 #define FUNC_NAME s_scm_caaddr
 331 {
 332   CHASE_PAIRS (x, "caaddr", 0xfa); /* 11111010 */
 333 }
 334 #undef FUNC_NAME
 335
 336 SCM_DEFINE (scm_caadar, "caadar", 1, 0, 0, (SCM x), "")
 337 #define FUNC_NAME s_scm_caadar
 338 {
 339   CHASE_PAIRS (x, "caadar", 0xfb); /* 11111011 */
 340 }
 341 #undef FUNC_NAME
 342
 343 SCM_DEFINE (scm_caaadr, "caaadr", 1, 0, 0, (SCM x), "")
 344 #define FUNC_NAME s_scm_caaadr
 345 {
 346   CHASE_PAIRS (x, "caaadr", 0xfe); /* 11111110 */
 347 }
 348 #undef FUNC_NAME
 349
 350 SCM_DEFINE (scm_caaaar, "caaaar", 1, 0, 0, (SCM x), "")
 351 #define FUNC_NAME s_scm_caaaar
 352 {
 353   CHASE_PAIRS (x, "caaaar", 0xff); /* 11111111 */
 354 }
 355 #undef FUNC_NAME
 356
 357
 358 \f
 359
 360 void
 361 scm_init_pairs ()
 362 {
 363 #include "libguile/pairs.x"
 364 }
 365
 366
 367 /*
 368   Local Variables:
 369   c-file-style: "gnu"
 370   End:
 371 */