123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281 |
- #ifdef HAVE_CONFIG_H
- # include <config.h>
- #endif
- #include "libguile/_scm.h"
- #include "libguile/validate.h"
- #include "libguile/pairs.h"
- #include "verify.h"
- verify (SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
- (SCM_ELISP_NIL_BITS, SCM_EOL_BITS));
- #if (SCM_DEBUG_PAIR_ACCESSES == 1)
- #include "libguile/ports.h"
- #include "libguile/strings.h"
- void scm_error_pair_access (SCM non_pair)
- {
- static unsigned int running = 0;
- SCM message = scm_from_locale_string ("Non-pair accessed with SCM_C[AD]R: `~S'\n");
- if (!running)
- {
- running = 1;
- scm_simple_format (scm_current_error_port (),
- message, scm_list_1 (non_pair));
- abort ();
- }
- }
- #endif
- SCM_DEFINE (scm_cons, "cons", 2, 0, 0,
- (SCM x, SCM y),
- "Return a newly allocated pair whose car is @var{x} and whose\n"
- "cdr is @var{y}. The pair is guaranteed to be different (in the\n"
- "sense of @code{eq?}) from every previously existing object.")
- #define FUNC_NAME s_scm_cons
- {
- return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y));
- }
- #undef FUNC_NAME
- SCM
- scm_cons2 (SCM w, SCM x, SCM y)
- {
- return scm_cons (w, scm_cons (x, y));
- }
- SCM_DEFINE (scm_pair_p, "pair?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} if @var{x} is a pair; otherwise return\n"
- "@code{#f}.")
- #define FUNC_NAME s_scm_pair_p
- {
- return scm_from_bool (scm_is_pair (x));
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_set_car_x, "set-car!", 2, 0, 0,
- (SCM pair, SCM value),
- "Stores @var{value} in the car field of @var{pair}. The value returned\n"
- "by @code{set-car!} is unspecified.")
- #define FUNC_NAME s_scm_set_car_x
- {
- SCM_VALIDATE_CONS (1, pair);
- SCM_SETCAR (pair, value);
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0,
- (SCM pair, SCM value),
- "Stores @var{value} in the cdr field of @var{pair}. The value returned\n"
- "by @code{set-cdr!} is unspecified.")
- #define FUNC_NAME s_scm_set_cdr_x
- {
- SCM_VALIDATE_CONS (1, pair);
- SCM_SETCDR (pair, value);
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- #define CHASE_PAIRS(tree, FUNC_NAME, pattern) \
- scm_t_uint32 pattern_var = pattern; \
- do \
- { \
- if (!scm_is_pair (tree)) \
- scm_wrong_type_arg_msg (FUNC_NAME, 0, tree, "pair"); \
- tree = (pattern_var & 1) ? SCM_CAR (tree) : SCM_CDR (tree); \
- pattern_var >>= 2; \
- } \
- while (pattern_var); \
- return tree
- SCM_DEFINE (scm_cdr, "cdr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cdr", 0x02);
- }
- SCM_DEFINE (scm_car, "car", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "car", 0x03);
- }
- SCM_DEFINE (scm_cddr, "cddr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cddr", 0x0a);
- }
- SCM_DEFINE (scm_cdar, "cdar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cdar", 0x0b);
- }
- SCM_DEFINE (scm_cadr, "cadr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cadr", 0x0e);
- }
- SCM_DEFINE (scm_caar, "caar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "caar", 0x0f);
- }
- SCM_DEFINE (scm_cdddr, "cdddr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cdddr", 0x2a);
- }
- SCM_DEFINE (scm_cddar, "cddar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cddar", 0x2b);
- }
- SCM_DEFINE (scm_cdadr, "cdadr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cdadr", 0x2e);
- }
- SCM_DEFINE (scm_cdaar, "cdaar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cdaar", 0x2f);
- }
- SCM_DEFINE (scm_caddr, "caddr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "caddr", 0x3a);
- }
- SCM_DEFINE (scm_cadar, "cadar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cadar", 0x3b);
- }
- SCM_DEFINE (scm_caadr, "caadr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "caadr", 0x3e);
- }
- SCM_DEFINE (scm_caaar, "caaar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "caaar", 0x3f);
- }
- SCM_DEFINE (scm_cddddr, "cddddr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cddddr", 0xaa);
- }
- SCM_DEFINE (scm_cdddar, "cdddar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cdddar", 0xab);
- }
- SCM_DEFINE (scm_cddadr, "cddadr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cddadr", 0xae);
- }
- SCM_DEFINE (scm_cddaar, "cddaar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cddaar", 0xaf);
- }
- SCM_DEFINE (scm_cdaddr, "cdaddr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cdaddr", 0xba);
- }
- SCM_DEFINE (scm_cdadar, "cdadar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cdadar", 0xbb);
- }
- SCM_DEFINE (scm_cdaadr, "cdaadr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cdaadr", 0xbe);
- }
- SCM_DEFINE (scm_cdaaar, "cdaaar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cdaaar", 0xbf);
- }
- SCM_DEFINE (scm_cadddr, "cadddr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cadddr", 0xea);
- }
- SCM_DEFINE (scm_caddar, "caddar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "caddar", 0xeb);
- }
- SCM_DEFINE (scm_cadadr, "cadadr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cadadr", 0xee);
- }
- SCM_DEFINE (scm_cadaar, "cadaar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "cadaar", 0xef);
- }
- SCM_DEFINE (scm_caaddr, "caaddr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "caaddr", 0xfa);
- }
- SCM_DEFINE (scm_caadar, "caadar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "caadar", 0xfb);
- }
- SCM_DEFINE (scm_caaadr, "caaadr", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "caaadr", 0xfe);
- }
- SCM_DEFINE (scm_caaaar, "caaaar", 1, 0, 0, (SCM x), "")
- {
- CHASE_PAIRS (x, "caaaar", 0xff);
- }
- void
- scm_init_pairs ()
- {
- #include "libguile/pairs.x"
- }
|