mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 04:10:18 +02:00
162 lines
3.3 KiB
C
162 lines
3.3 KiB
C
/* Copyright (C) 1995,1996,2000,2001 Free Software Foundation, Inc.
|
||
*
|
||
* This library is free software; you can redistribute it and/or
|
||
* modify it under the terms of the GNU Lesser General Public
|
||
* License as published by the Free Software Foundation; either
|
||
* version 2.1 of the License, or (at your option) any later version.
|
||
*
|
||
* This library is distributed in the hope that it will be useful,
|
||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
* Lesser General Public License for more details.
|
||
*
|
||
* You should have received a copy of the GNU Lesser General Public
|
||
* License along with this library; if not, write to the Free Software
|
||
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||
*/
|
||
|
||
|
||
|
||
|
||
#include "libguile/_scm.h"
|
||
#include "libguile/validate.h"
|
||
|
||
#include "libguile/pairs.h"
|
||
|
||
|
||
|
||
/* {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),
|
||
"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_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_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
|
||
|
||
|
||
|
||
static const char * cxrs[] =
|
||
{
|
||
"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
|
||
};
|
||
|
||
|
||
|
||
void
|
||
scm_init_pairs ()
|
||
{
|
||
unsigned int subnr = 0;
|
||
|
||
for (subnr = 0; cxrs [subnr]; subnr++)
|
||
scm_c_define_subr (cxrs [subnr], scm_tc7_cxr, NULL);
|
||
|
||
#include "libguile/pairs.x"
|
||
}
|
||
|
||
|
||
/*
|
||
Local Variables:
|
||
c-file-style: "gnu"
|
||
End:
|
||
*/
|