mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 00:30:21 +02:00
Code Activity

* tests/goops.test: New tests.

Browse source 
* goops.scm (equal?): Provide default method for `equal?'.
(compute-getters-n-setters): Check for bad init-thunks.

* eq.c (scm_equal_p): Turned into a primitive generic.

* snarf.h (SCM_PRIMITIVE_GENERIC, SCM_PRIMITIVE_GENERIC_1): New
macros.
This commit is contained in:
Mikael Djurfeldt 2003-04-17 17:50:57 +00:00
parent 95a0ecc3c7
commit 071d6b0ecc
8 changed files with 285 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

7
libguile/ChangeLog
View file

@ -1,3 +1,10 @@
2003-04-17 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* eq.c (scm_equal_p): Turned into a primitive generic.
* snarf.h (SCM_PRIMITIVE_GENERIC, SCM_PRIMITIVE_GENERIC_1): New
macros.
2003-04-16 Rob Browning <rlb@defaultvalue.org>
* gc_os_dep.c: Added patch for UnixWare and OpenUNIX support.

27
libguile/eq.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003 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
@ -115,14 +115,14 @@ SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
#undef FUNC_NAME
SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent.\n"
"@code{equal?} recursively compares the contents of pairs,\n"
"vectors, and strings, applying @code{eqv?} on other objects such as\n"
"numbers and symbols. A rule of thumb is that objects are generally\n"
"@code{equal?} if they print the same. @code{equal?} may fail to\n"
"terminate if its arguments are circular data structures.")
SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent.\n"
"@code{equal?} recursively compares the contents of pairs,\n"
"vectors, and strings, applying @code{eqv?} on other objects such as\n"
"numbers and symbols. A rule of thumb is that objects are generally\n"
"@code{equal?} if they print the same. @code{equal?} may fail to\n"
"terminate if its arguments are circular data structures.")
#define FUNC_NAME s_scm_equal_p
{
SCM_CHECK_STACK;
@ -164,7 +164,7 @@ SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
switch (SCM_TYP7 (x))
{
default:
return SCM_BOOL_F;
break;
case scm_tc7_vector:
case scm_tc7_wvect:
return scm_vector_equal_p (x, y);
@ -176,7 +176,7 @@ SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
if (scm_smobs[i].equalp)
return (scm_smobs[i].equalp) (x, y);
else
return SCM_BOOL_F;
break;
}
#ifdef HAVE_ARRAYS
case scm_tc7_bvect: case scm_tc7_uvect: case scm_tc7_ivect:
@ -190,7 +190,10 @@ SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
return scm_array_equal_p (x, y);
#endif
}
return SCM_BOOL_F;
if (SCM_UNPACK (g_scm_equal_p))
return scm_call_generic_2 (g_scm_equal_p, x, y);
else
return SCM_BOOL_F;
}
#undef FUNC_NAME

28
libguile/snarf.h
View file

@ -5,7 +5,7 @@
#ifndef LIBGUILE_SNARF_H
#define LIBGUILE_SNARF_H
/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc.
/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001, 2003 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
@ -109,6 +109,20 @@ scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
)\
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
#define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\
static const char s_ ## FNAME [] = PRIMNAME; \
static SCM g_ ## FNAME; \
SCM FNAME ARGLIST\
)\
SCM_SNARF_INIT(\
g_ ## FNAME = SCM_PACK (0); \
scm_c_define_gsubr_with_generic (s_ ## FNAME, REQ, OPT, VAR, \
(SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME, \
&g_ ## FNAME); \
)\
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
#define SCM_DEFINE1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\
static const char s_ ## FNAME [] = PRIMNAME; \
@ -117,6 +131,18 @@ SCM FNAME ARGLIST\
SCM_SNARF_INIT(scm_c_define_subr (s_ ## FNAME, TYPE, FNAME); ) \
SCM_SNARF_DOCS(1, FNAME, PRIMNAME, ARGLIST, 2, 0, 0, DOCSTRING)
#define SCM_PRIMITIVE_GENERIC_1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\
static const char s_ ## FNAME [] = PRIMNAME; \
static SCM g_ ## FNAME; \
SCM FNAME ARGLIST\
)\
SCM_SNARF_INIT(\
g_ ## FNAME = SCM_PACK (0); \
scm_c_define_subr_with_generic (s_ ## FNAME, TYPE, FNAME, &g_ ## FNAME); \
)\
SCM_SNARF_DOCS(1, FNAME, PRIMNAME, ARGLIST, 2, 0, 0, DOCSTRING)
#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
SCM_SNARF_HERE(static const char RANAME[]=STR) \
SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \