-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
+
+
\f
-#include <stdio.h>
-#include "_scm.h"
+
+#include "libguile/_scm.h"
+#include "libguile/validate.h"
+
+#include "libguile/pairs.h"
\f
/* {Pairs}
*/
-SCM_PROC(s_cons, "cons", 2, 0, 0, scm_cons);
+#if (SCM_DEBUG_PAIR_ACCESSES == 1)
-SCM
-scm_cons (x, y)
- SCM x;
- SCM y;
+#include "libguile/ports.h"
+#include "libguile/strings.h"
+
+void scm_error_pair_access (SCM non_pair)
{
- register SCM z;
- SCM_NEWCELL (z);
- SCM_SETCAR (z, x);
- SCM_SETCDR (z, y);
- return z;
+ static unsigned int running = 0;
+ SCM message = scm_makfrom0str ("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
-scm_cons2 (w, x, y)
- SCM w;
- SCM x;
- SCM y;
+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
{
- register SCM z;
+ SCM z;
SCM_NEWCELL (z);
- SCM_SETCAR (z, x);
- SCM_SETCDR (z, y);
- x = z;
- SCM_NEWCELL (z);
- SCM_SETCAR (z, w);
- SCM_SETCDR (z, x);
+ SCM_SET_CELL_OBJECT_0 (z, x);
+ SCM_SET_CELL_OBJECT_1 (z, y);
return z;
}
+#undef FUNC_NAME
-SCM_PROC (s_pair_p, "pair?", 1, 0, 0, scm_pair_p);
+SCM
+scm_cons2 (SCM w, SCM x, SCM y)
+{
+ SCM z1;
+ SCM z2;
+
+ SCM_NEWCELL (z1);
+ SCM_SET_CELL_OBJECT_0 (z1, x);
+ SCM_SET_CELL_OBJECT_1 (z1, y);
+
+ SCM_NEWCELL (z2);
+ SCM_SET_CELL_OBJECT_0 (z2, w);
+ SCM_SET_CELL_OBJECT_1 (z2, z1);
+
+ return z2;
+}
-SCM
-scm_pair_p (x)
- SCM x;
+
+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
{
- if (SCM_IMP (x))
- return SCM_BOOL_F;
- return SCM_CONSP (x) ? SCM_BOOL_T : SCM_BOOL_F;
+ return SCM_BOOL (SCM_CONSP (x));
}
+#undef FUNC_NAME
-SCM_PROC (s_set_car_x, "set-car!", 2, 0, 0, scm_set_car_x);
-SCM
-scm_set_car_x (pair, value)
- SCM pair;
- SCM value;
+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_ASSERT (SCM_NIMP (pair) && SCM_CONSP (pair),
- pair, SCM_ARG1, s_set_car_x);
+ SCM_VALIDATE_CONS (1, pair);
SCM_SETCAR (pair, value);
- return value;
+ return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
-SCM_PROC (s_set_cdr_x, "set-cdr!", 2, 0, 0, scm_set_cdr_x);
-SCM
-scm_set_cdr_x (pair, value)
- SCM pair;
- SCM value;
+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_ASSERT (SCM_NIMP(pair) && SCM_CONSP (pair), pair, SCM_ARG1, s_set_cdr_x);
+ SCM_VALIDATE_CONS (1, pair);
SCM_SETCDR (pair, value);
- return value;
+ return SCM_UNSPECIFIED;
}
-
+#undef FUNC_NAME
\f
-static const scm_iproc cxrs[] =
+static const char * cxrs[] =
{
- {"car", 0},
- {"cdr", 0},
- {"caar", 0},
- {"cadr", 0},
- {"cdar", 0},
- {"cddr", 0},
- {"caaar", 0},
- {"caadr", 0},
- {"cadar", 0},
- {"caddr", 0},
- {"cdaar", 0},
- {"cdadr", 0},
- {"cddar", 0},
- {"cdddr", 0},
- {"caaaar", 0},
- {"caaadr", 0},
- {"caadar", 0},
- {"caaddr", 0},
- {"cadaar", 0},
- {"cadadr", 0},
- {"caddar", 0},
- {"cadddr", 0},
- {"cdaaar", 0},
- {"cdaadr", 0},
- {"cdadar", 0},
- {"cdaddr", 0},
- {"cddaar", 0},
- {"cddadr", 0},
- {"cdddar", 0},
- {"cddddr", 0},
- {0, 0}
+ "car",
+ "cdr",
+ "caar",
+ "cadr",
+ "cdar",
+ "cddr",
+ "caaar",
+ "caadr",
+ "cadar",
+ "caddr",
+ "cdaar",
+ "cdadr",
+ "cddar",
+ "cdddr",
+ "caaaar",
+ "caaadr",
+ "caadar",
+ "caaddr",
+ "cadaar",
+ "cadadr",
+ "caddar",
+ "cadddr",
+ "cdaaar",
+ "cdaadr",
+ "cdadar",
+ "cdaddr",
+ "cddaar",
+ "cddadr",
+ "cdddar",
+ "cddddr",
+ 0
};
\f
void
scm_init_pairs ()
{
- scm_init_iprocs (cxrs, scm_tc7_cxr);
-#include "pairs.x"
+ unsigned int subnr = 0;
+
+ for (subnr = 0; cxrs [subnr]; subnr++)
+ scm_c_define_subr (cxrs [subnr], scm_tc7_cxr, NULL);
+
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/pairs.x"
+#endif
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/