* eval.c (RETURN): Wrap in do{}while(0) in order to make it

[bpt/guile.git] / libguile / pairs.c

diff --git a/libguile/pairs.c b/libguile/pairs.c
index 21415b3..88ce017 100644 (file)
--- a/libguile/pairs.c
+++ b/libguile/pairs.c
@@ -1,4 +1,4 @@
-/*     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
@@ -39,30 +39,51 @@
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.  */
 
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
-   gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
 
 \f
-#include <stdio.h>
-#include "_scm.h"
 
+#include "libguile/_scm.h"
+#include "libguile/validate.h"
 
-#include "scm_validate.h"
+#include "libguile/pairs.h"
 
 \f
 
 /* {Pairs}
  */
 
+#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_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_DEFINE (scm_cons, "cons", 2, 0, 0,
-           (SCM x, SCM y),
-"")
+           (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);
+  SCM_SET_CELL_OBJECT_0 (z, x);
+  SCM_SET_CELL_OBJECT_1 (z, y);
   return z;
 }
 #undef FUNC_NAME
@@ -71,87 +92,92 @@ SCM_DEFINE (scm_cons, "cons", 2, 0, 0,
 SCM 
 scm_cons2 (SCM w, SCM x, SCM y)
 {
-  register 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);
-  return z;
+  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_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_BOOL(SCM_CONSP (x));
+  return SCM_BOOL (SCM_CONSP (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_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_VALIDATE_CONS (1, pair);
   SCM_SETCDR (pair, 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
@@ -159,7 +185,19 @@ static const scm_iproc cxrs[] =
 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:
+*/