summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/.cvsignore1
-rw-r--r--libguile/ChangeLog20
-rw-r--r--libguile/environments.c3
-rw-r--r--libguile/gc.h10
-rw-r--r--libguile/macros.c1
-rw-r--r--libguile/net_db.c67
-rw-r--r--libguile/posix.c68
-rw-r--r--libguile/socket.c32
-rw-r--r--libguile/sort.c88
-rw-r--r--libguile/vectors.c13
10 files changed, 159 insertions, 144 deletions
diff --git a/libguile/.cvsignore b/libguile/.cvsignore
index d5d8f2a5e..9df5f259b 100644
--- a/libguile/.cvsignore
+++ b/libguile/.cvsignore
@@ -22,6 +22,7 @@ errnos.list
fd.h
gh_test_c
gh_test_repl
+goops.c
guile
guile-doc-snarf
guile-func-name-check
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 3f95b31ed..5aa4ce9ab 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,23 @@
+2002-07-21 Han-Wen <hanwen@cs.uu.nl>
+
+ * goops.c (scm_compute_applicable_methods): use
+ scm_remember_upto_here_1 iso scm_remember_upto_here
+
+ * macros.c: include deprecation.h
+
+ * vectors.c (s_scm_vector_move_right_x): remove side effect in
+ macro arg.
+ (s_scm_vector_move_left_x): idem.
+
+ * net_db.c, posix.c, socket.c: variable naming: change ans to
+ result.
+
+ * sort.c (scm_merge_vector_x): accept vector as argument
+ iso. SCM*. This is needed for full GC correctness.
+
+ * gc.h: undo previous undocumented changes related to #ifdef
+ GENGC.
+
2002-07-20 Han-Wen <hanwen@cs.uu.nl>
* *.c: add space after commas everywhere.
diff --git a/libguile/environments.c b/libguile/environments.c
index a5cc3c244..26cf424e2 100644
--- a/libguile/environments.c
+++ b/libguile/environments.c
@@ -594,6 +594,9 @@ obarray_retrieve (SCM obarray, SCM sym)
PRECONDITION:
length (ALIST) >= 1
+
+ This could also be done by combining scm_delq1_x () and
+ scm_sloppy_assq(), at the cost of walking the list another time.
*/
static
SCM
diff --git a/libguile/gc.h b/libguile/gc.h
index 72ac83074..0296ea0e0 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -80,22 +80,12 @@ typedef scm_t_cell * SCM_CELLPTR;
# define PTR2SCM(x) (SCM_PACK ((scm_t_bits) (x)))
#endif /* def _UNICOS */
-#ifdef GENGC
-/*
- TODO
- */
-#else /* ! genGC */
-
#define SCM_GC_CARD_N_HEADER_CELLS 1
#define SCM_GC_CARD_N_CELLS 256
-#define SCM_GC_CARD_GENERATION(card)
-#define SCM_GC_FLAG_OBJECT_WRITE(x)
-
#define SCM_GC_CARD_BVEC(card) ((scm_t_c_bvec_limb *) ((card)->word_0))
#define SCM_GC_SET_CARD_BVEC(card, bvec) \
((card)->word_0 = (scm_t_bits) (bvec))
-#endif
#define SCM_GC_CARD_SIZE (SCM_GC_CARD_N_CELLS * sizeof (scm_t_cell))
diff --git a/libguile/macros.c b/libguile/macros.c
index 77c068519..55fae13d6 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -49,6 +49,7 @@
#include "libguile/print.h"
#include "libguile/root.h"
#include "libguile/smob.h"
+#include "libguile/deprecation.h"
#include "libguile/validate.h"
#include "libguile/macros.h"
diff --git a/libguile/net_db.c b/libguile/net_db.c
index 12885642e..f5a6537dc 100644
--- a/libguile/net_db.c
+++ b/libguile/net_db.c
@@ -153,8 +153,7 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0,
"@code{system-error} or @code{misc_error} keys.")
#define FUNC_NAME s_scm_gethost
{
- SCM ans = scm_c_make_vector (5, SCM_UNSPECIFIED);
- SCM *ve = SCM_WRITABLE_VELTS (ans);
+ SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED);
SCM lst = SCM_EOL;
struct hostent *entry;
struct in_addr inad;
@@ -190,14 +189,14 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0,
if (!entry)
scm_resolv_error (FUNC_NAME, host);
- SCM_VECTOR_SET(ans, 0, scm_mem2string (entry->h_name, strlen (entry->h_name)));
- SCM_VECTOR_SET(ans, 1, scm_makfromstrs (-1, entry->h_aliases));
- SCM_VECTOR_SET(ans, 2, SCM_MAKINUM (entry->h_addrtype + 0L));
- SCM_VECTOR_SET(ans, 3, SCM_MAKINUM (entry->h_length + 0L));
+ SCM_VECTOR_SET(result, 0, scm_mem2string (entry->h_name, strlen (entry->h_name)));
+ SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->h_aliases));
+ SCM_VECTOR_SET(result, 2, SCM_MAKINUM (entry->h_addrtype + 0L));
+ SCM_VECTOR_SET(result, 3, SCM_MAKINUM (entry->h_length + 0L));
if (sizeof (struct in_addr) != entry->h_length)
{
- SCM_VECTOR_SET(ans, 4, SCM_BOOL_F);
- return ans;
+ SCM_VECTOR_SET(result, 4, SCM_BOOL_F);
+ return result;
}
for (argv = entry->h_addr_list; argv[i]; i++);
while (i--)
@@ -205,8 +204,8 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0,
inad = *(struct in_addr *) argv[i];
lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
}
- SCM_VECTOR_SET(ans, 4, lst);
- return ans;
+ SCM_VECTOR_SET(result, 4, lst);
+ return result;
}
#undef FUNC_NAME
@@ -232,13 +231,9 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0,
"given.")
#define FUNC_NAME s_scm_getnet
{
- SCM ans;
- SCM *ve;
+ SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED);
struct netent *entry;
- ans = scm_c_make_vector (4, SCM_UNSPECIFIED);
- ve = SCM_WRITABLE_VELTS (ans);
-
if (SCM_UNBNDP (net))
{
entry = getnetent ();
@@ -262,11 +257,11 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0,
}
if (!entry)
SCM_SYSERROR_MSG ("no such network ~A", scm_list_1 (net), errno);
- SCM_VECTOR_SET(ans, 0, scm_mem2string (entry->n_name, strlen (entry->n_name)));
- SCM_VECTOR_SET(ans, 1, scm_makfromstrs (-1, entry->n_aliases));
- SCM_VECTOR_SET(ans, 2, SCM_MAKINUM (entry->n_addrtype + 0L));
- SCM_VECTOR_SET(ans, 3, scm_ulong2num (entry->n_net + 0L));
- return ans;
+ SCM_VECTOR_SET(result, 0, scm_mem2string (entry->n_name, strlen (entry->n_name)));
+ SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->n_aliases));
+ SCM_VECTOR_SET(result, 2, SCM_MAKINUM (entry->n_addrtype + 0L));
+ SCM_VECTOR_SET(result, 3, scm_ulong2num (entry->n_net + 0L));
+ return result;
}
#undef FUNC_NAME
#endif
@@ -282,12 +277,9 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0,
"@code{getprotoent} (see below) if no arguments are supplied.")
#define FUNC_NAME s_scm_getproto
{
- SCM ans;
- SCM *ve;
- struct protoent *entry;
+ SCM result = scm_c_make_vector (3, SCM_UNSPECIFIED);
- ans = scm_c_make_vector (3, SCM_UNSPECIFIED);
- ve = SCM_WRITABLE_VELTS (ans);
+ struct protoent *entry;
if (SCM_UNBNDP (protocol))
{
entry = getprotoent ();
@@ -311,10 +303,10 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0,
}
if (!entry)
SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol), errno);
- SCM_VECTOR_SET(ans, 0, scm_mem2string (entry->p_name, strlen (entry->p_name)));
- SCM_VECTOR_SET(ans, 1, scm_makfromstrs (-1, entry->p_aliases));
- SCM_VECTOR_SET(ans, 2, SCM_MAKINUM (entry->p_proto + 0L));
- return ans;
+ SCM_VECTOR_SET(result, 0, scm_mem2string (entry->p_name, strlen (entry->p_name)));
+ SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->p_aliases));
+ SCM_VECTOR_SET(result, 2, SCM_MAKINUM (entry->p_proto + 0L));
+ return result;
}
#undef FUNC_NAME
#endif
@@ -323,16 +315,13 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0,
static SCM
scm_return_entry (struct servent *entry)
{
- SCM ans;
- SCM *ve;
-
- ans = scm_c_make_vector (4, SCM_UNSPECIFIED);
- ve = SCM_WRITABLE_VELTS (ans);
- SCM_VECTOR_SET(ans, 0, scm_mem2string (entry->s_name, strlen (entry->s_name)));
- SCM_VECTOR_SET(ans, 1, scm_makfromstrs (-1, entry->s_aliases));
- SCM_VECTOR_SET(ans, 2, SCM_MAKINUM (ntohs (entry->s_port) + 0L));
- SCM_VECTOR_SET(ans, 3, scm_mem2string (entry->s_proto, strlen (entry->s_proto)));
- return ans;
+ SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED);
+
+ SCM_VECTOR_SET(result, 0, scm_mem2string (entry->s_name, strlen (entry->s_name)));
+ SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->s_aliases));
+ SCM_VECTOR_SET(result, 2, SCM_MAKINUM (ntohs (entry->s_port) + 0L));
+ SCM_VECTOR_SET(result, 3, scm_mem2string (entry->s_proto, strlen (entry->s_proto)));
+ return result;
}
SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0,
diff --git a/libguile/posix.c b/libguile/posix.c
index f9d8a22e0..a4da1a8cf 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -222,7 +222,7 @@ SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0,
"supplementary group IDs.")
#define FUNC_NAME s_scm_getgroups
{
- SCM ans;
+ SCM result;
int ngroups;
size_t size;
GETGROUPS_T *groups;
@@ -235,16 +235,16 @@ SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0,
groups = scm_malloc (size);
getgroups (ngroups, groups);
- ans = scm_c_make_vector (ngroups, SCM_UNDEFINED);
+ result = scm_c_make_vector (ngroups, SCM_UNDEFINED);
{
- SCM * ve = SCM_WRITABLE_VELTS(ans);
+ SCM * ve = SCM_WRITABLE_VELTS(result);
while (--ngroups >= 0)
ve[ngroups] = SCM_MAKINUM (groups [ngroups]);
}
free (groups);
- return ans;
+ return result;
}
#undef FUNC_NAME
#endif
@@ -259,7 +259,7 @@ SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0,
{
struct passwd *entry;
- SCM ans = scm_c_make_vector (7, SCM_UNSPECIFIED);
+ SCM result = scm_c_make_vector (7, SCM_UNSPECIFIED);
if (SCM_UNBNDP (user) || SCM_FALSEP (user))
{
SCM_SYSCALL (entry = getpwent ());
@@ -280,20 +280,20 @@ SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0,
if (!entry)
SCM_MISC_ERROR ("entry not found", SCM_EOL);
- SCM_VECTOR_SET(ans, 0, scm_makfrom0str (entry->pw_name));
- SCM_VECTOR_SET(ans, 1, scm_makfrom0str (entry->pw_passwd));
- SCM_VECTOR_SET(ans, 2, scm_ulong2num ((unsigned long) entry->pw_uid));
- SCM_VECTOR_SET(ans, 3, scm_ulong2num ((unsigned long) entry->pw_gid));
- SCM_VECTOR_SET(ans, 4, scm_makfrom0str (entry->pw_gecos));
+ SCM_VECTOR_SET(result, 0, scm_makfrom0str (entry->pw_name));
+ SCM_VECTOR_SET(result, 1, scm_makfrom0str (entry->pw_passwd));
+ SCM_VECTOR_SET(result, 2, scm_ulong2num ((unsigned long) entry->pw_uid));
+ SCM_VECTOR_SET(result, 3, scm_ulong2num ((unsigned long) entry->pw_gid));
+ SCM_VECTOR_SET(result, 4, scm_makfrom0str (entry->pw_gecos));
if (!entry->pw_dir)
- SCM_VECTOR_SET(ans, 5, scm_makfrom0str (""));
+ SCM_VECTOR_SET(result, 5, scm_makfrom0str (""));
else
- SCM_VECTOR_SET(ans, 5, scm_makfrom0str (entry->pw_dir));
+ SCM_VECTOR_SET(result, 5, scm_makfrom0str (entry->pw_dir));
if (!entry->pw_shell)
- SCM_VECTOR_SET(ans, 6, scm_makfrom0str (""));
+ SCM_VECTOR_SET(result, 6, scm_makfrom0str (""));
else
- SCM_VECTOR_SET(ans, 6, scm_makfrom0str (entry->pw_shell));
- return ans;
+ SCM_VECTOR_SET(result, 6, scm_makfrom0str (entry->pw_shell));
+ return result;
}
#undef FUNC_NAME
#endif /* HAVE_GETPWENT */
@@ -327,7 +327,7 @@ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0,
#define FUNC_NAME s_scm_getgrgid
{
struct group *entry;
- SCM ans = scm_c_make_vector (4, SCM_UNSPECIFIED);
+ SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED);
if (SCM_UNBNDP (name) || SCM_FALSEP (name))
{
@@ -347,11 +347,11 @@ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0,
if (!entry)
SCM_SYSERROR;
- SCM_VECTOR_SET(ans, 0, scm_makfrom0str (entry->gr_name));
- SCM_VECTOR_SET(ans, 1, scm_makfrom0str (entry->gr_passwd));
- SCM_VECTOR_SET(ans, 2, scm_ulong2num ((unsigned long) entry->gr_gid));
- SCM_VECTOR_SET(ans, 3, scm_makfromstrs (-1, entry->gr_mem));
- return ans;
+ SCM_VECTOR_SET(result, 0, scm_makfrom0str (entry->gr_name));
+ SCM_VECTOR_SET(result, 1, scm_makfrom0str (entry->gr_passwd));
+ SCM_VECTOR_SET(result, 2, scm_ulong2num ((unsigned long) entry->gr_gid));
+ SCM_VECTOR_SET(result, 3, scm_makfromstrs (-1, entry->gr_mem));
+ return result;
}
#undef FUNC_NAME
@@ -741,7 +741,7 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
"underlying @var{port}.")
#define FUNC_NAME s_scm_ttyname
{
- char *ans;
+ char *result;
int fd;
port = SCM_COERCE_OUTPORT (port);
@@ -749,11 +749,11 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
if (!SCM_FPORTP (port))
return SCM_BOOL_F;
fd = SCM_FPORT_FDES (port);
- SCM_SYSCALL (ans = ttyname (fd));
- if (!ans)
+ SCM_SYSCALL (result = ttyname (fd));
+ if (!result)
SCM_SYSERROR;
- /* ans could be overwritten by another call to ttyname */
- return (scm_makfrom0str (ans));
+ /* result could be overwritten by another call to ttyname */
+ return (scm_makfrom0str (result));
}
#undef FUNC_NAME
#endif /* HAVE_TTYNAME */
@@ -982,19 +982,19 @@ SCM_DEFINE (scm_uname, "uname", 0, 0, 0,
#define FUNC_NAME s_scm_uname
{
struct utsname buf;
- SCM ans = scm_c_make_vector (5, SCM_UNSPECIFIED);
+ SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED);
if (uname (&buf) < 0)
SCM_SYSERROR;
- SCM_VECTOR_SET(ans, 0, scm_makfrom0str (buf.sysname));
- SCM_VECTOR_SET(ans, 1, scm_makfrom0str (buf.nodename));
- SCM_VECTOR_SET(ans, 2, scm_makfrom0str (buf.release));
- SCM_VECTOR_SET(ans, 3, scm_makfrom0str (buf.version));
- SCM_VECTOR_SET(ans, 4, scm_makfrom0str (buf.machine));
+ SCM_VECTOR_SET(result, 0, scm_makfrom0str (buf.sysname));
+ SCM_VECTOR_SET(result, 1, scm_makfrom0str (buf.nodename));
+ SCM_VECTOR_SET(result, 2, scm_makfrom0str (buf.release));
+ SCM_VECTOR_SET(result, 3, scm_makfrom0str (buf.version));
+ SCM_VECTOR_SET(result, 4, scm_makfrom0str (buf.machine));
/*
a linux special?
- SCM_VECTOR_SET(ans, 5, scm_makfrom0str (buf.domainname));
+ SCM_VECTOR_SET(result, 5, scm_makfrom0str (buf.domainname));
*/
- return ans;
+ return result;
}
#undef FUNC_NAME
#endif /* HAVE_UNAME */
diff --git a/libguile/socket.c b/libguile/socket.c
index 5ea34d78a..bf1dc019e 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -925,7 +925,7 @@ static SCM
scm_addr_vector (const struct sockaddr *address, const char *proc)
{
short int fam = address->sa_family;
- SCM ans =SCM_EOL;
+ SCM result =SCM_EOL;
switch (fam)
@@ -934,11 +934,11 @@ scm_addr_vector (const struct sockaddr *address, const char *proc)
{
const struct sockaddr_in *nad = (struct sockaddr_in *) address;
- ans = scm_c_make_vector (3, SCM_UNSPECIFIED);
+ result = scm_c_make_vector (3, SCM_UNSPECIFIED);
- SCM_VECTOR_SET(ans, 0, scm_ulong2num ((unsigned long) fam));
- SCM_VECTOR_SET(ans, 1, scm_ulong2num (ntohl (nad->sin_addr.s_addr)));
- SCM_VECTOR_SET(ans, 2, scm_ulong2num ((unsigned long) ntohs (nad->sin_port)));
+ SCM_VECTOR_SET(result, 0, scm_ulong2num ((unsigned long) fam));
+ SCM_VECTOR_SET(result, 1, scm_ulong2num (ntohl (nad->sin_addr.s_addr)));
+ SCM_VECTOR_SET(result, 2, scm_ulong2num ((unsigned long) ntohs (nad->sin_port)));
}
break;
#ifdef HAVE_IPV6
@@ -946,15 +946,15 @@ scm_addr_vector (const struct sockaddr *address, const char *proc)
{
const struct sockaddr_in6 *nad = (struct sockaddr_in6 *) address;
- ans = scm_c_make_vector (5, SCM_UNSPECIFIED);
- SCM_VECTOR_SET(ans, 0, scm_ulong2num ((unsigned long) fam));
- SCM_VECTOR_SET(ans, 1, ipv6_net_to_num (nad->sin6_addr.s6_addr));
- SCM_VECTOR_SET(ans, 2, scm_ulong2num ((unsigned long) ntohs (nad->sin6_port)));
- SCM_VECTOR_SET(ans, 3, scm_ulong2num ((unsigned long) nad->sin6_flowinfo));
+ result = scm_c_make_vector (5, SCM_UNSPECIFIED);
+ SCM_VECTOR_SET(result, 0, scm_ulong2num ((unsigned long) fam));
+ SCM_VECTOR_SET(result, 1, ipv6_net_to_num (nad->sin6_addr.s6_addr));
+ SCM_VECTOR_SET(result, 2, scm_ulong2num ((unsigned long) ntohs (nad->sin6_port)));
+ SCM_VECTOR_SET(result, 3, scm_ulong2num ((unsigned long) nad->sin6_flowinfo));
#ifdef HAVE_SIN6_SCOPE_ID
- SCM_VECTOR_SET(ans, 4, scm_ulong2num ((unsigned long) nad->sin6_scope_id));
+ SCM_VECTOR_SET(result, 4, scm_ulong2num ((unsigned long) nad->sin6_scope_id));
#else
- SCM_VECTOR_SET(ans, 4, SCM_INUM0);
+ SCM_VECTOR_SET(result, 4, SCM_INUM0);
#endif
}
break;
@@ -964,10 +964,10 @@ scm_addr_vector (const struct sockaddr *address, const char *proc)
{
const struct sockaddr_un *nad = (struct sockaddr_un *) address;
- ans = scm_c_make_vector (2, SCM_UNSPECIFIED);
+ result = scm_c_make_vector (2, SCM_UNSPECIFIED);
- SCM_VECTOR_SET(ans, 0, scm_ulong2num ((unsigned long) fam));
- SCM_VECTOR_SET(ans, 1, scm_mem2string (nad->sun_path, strlen (nad->sun_path)));
+ SCM_VECTOR_SET(result, 0, scm_ulong2num ((unsigned long) fam));
+ SCM_VECTOR_SET(result, 1, scm_mem2string (nad->sun_path, strlen (nad->sun_path)));
}
break;
#endif
@@ -975,7 +975,7 @@ scm_addr_vector (const struct sockaddr *address, const char *proc)
scm_misc_error (proc, "Unrecognised address family: ~A",
scm_list_1 (SCM_MAKINUM (fam)));
}
- return ans;
+ return result;
}
/* calculate the size of a buffer large enough to hold any supported
diff --git a/libguile/sort.c b/libguile/sort.c
index 8bca27c41..e8b332e42 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -437,7 +437,6 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
len = SCM_INUM (endpos) - spos;
quicksort (&vp[spos], len, size, scm_cmp_function (less), less);
- SCM_GC_FLAG_OBJECT_WRITE(vec);
return SCM_UNSPECIFIED;
/* return vec; */
@@ -784,43 +783,55 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
#undef FUNC_NAME
static void
-scm_merge_vector_x (void *const vecbase,
- void *const tempbase,
+scm_merge_vector_x (SCM vec,
+ SCM * temp,
cmp_fun_t cmp,
SCM less,
long low,
long mid,
long high)
{
- register SCM *vp = (SCM *) vecbase;
- register SCM *temp = (SCM *) tempbase;
long it; /* Index for temp vector */
long i1 = low; /* Index for lower vector segment */
long i2 = mid + 1; /* Index for upper vector segment */
/* Copy while both segments contain more characters */
for (it = low; (i1 <= mid) && (i2 <= high); ++it)
- if ((*cmp) (less, &vp[i2], &vp[i1]))
- temp[it] = vp[i2++];
- else
- temp[it] = vp[i1++];
-
- /* Copy while first segment contains more characters */
- while (i1 <= mid)
- temp[it++] = vp[i1++];
+ {
+ /*
+ Every call of LESS might invoke GC. For full correctness, we
+ should reset the generation of vecbase and tempbase between
+ every call of less.
- /* Copy while second segment contains more characters */
- while (i2 <= high)
- temp[it++] = vp[i2++];
+ */
+ register SCM *vp = SCM_WRITABLE_VELTS(vec);
+
+ if ((*cmp) (less, &vp[i2], &vp[i1]))
+ temp[it] = vp[i2++];
+ else
+ temp[it] = vp[i1++];
+ }
- /* Copy back from temp to vp */
- for (it = low; it <= high; ++it)
- vp[it] = temp[it];
-} /* scm_merge_vector_x */
+ {
+ register SCM *vp = SCM_WRITABLE_VELTS(vec);
+
+ /* Copy while first segment contains more characters */
+ while (i1 <= mid)
+ temp[it++] = vp[i1++];
+
+ /* Copy while second segment contains more characters */
+ while (i2 <= high)
+ temp[it++] = vp[i2++];
+
+ /* Copy back from temp to vp */
+ for (it = low; it <= high; ++it)
+ vp[it] = temp[it];
+ }
+} /* scm_merge_vector_x */
static void
-scm_merge_vector_step (void *const vp,
- void *const temp,
+scm_merge_vector_step (SCM vp,
+ SCM * temp,
cmp_fun_t cmp,
SCM less,
long low,
@@ -860,18 +871,16 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
}
else if (SCM_VECTORP (items))
{
- SCM *temp, *vp;
+ SCM *temp;
len = SCM_VECTOR_LENGTH (items);
- temp = malloc (len * sizeof(SCM));
-
- vp = SCM_WRITABLE_VELTS (items);
/*
- This routine modifies VP
- */
+ the following array does not contain any new references to
+ SCM objects, so we can get away with allocing it on the heap.
+ */
+ temp = malloc (len * sizeof(SCM));
- SCM_GC_FLAG_OBJECT_WRITE(items);
- scm_merge_vector_step (vp,
+ scm_merge_vector_step (items,
temp,
scm_cmp_function (less),
less,
@@ -886,7 +895,6 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
#undef FUNC_NAME
/* stable_sort manages lists and vectors */
-
SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
@@ -894,13 +902,14 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
"This is a stable sort.")
#define FUNC_NAME s_scm_stable_sort
{
- long len; /* list/vector length */
+
if (SCM_NULL_OR_NIL_P (items))
return items;
SCM_VALIDATE_NIM (2, less);
if (SCM_CONSP (items))
{
+ long len; /* list/vector length */
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
items = scm_list_copy (items);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
@@ -909,19 +918,12 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
/* support ordinary vectors even if arrays not available? */
else if (SCM_VECTORP (items))
{
- SCM retvec;
- SCM *temp, *vp;
- len = SCM_VECTOR_LENGTH (items);
- retvec = scm_make_uve (len, scm_array_prototype (items));
+ long len = SCM_VECTOR_LENGTH (items);
+ SCM *temp = malloc (len * sizeof (SCM));
+ SCM retvec = scm_make_uve (len, scm_array_prototype (items));
scm_array_copy_x (items, retvec);
- temp = malloc (len * sizeof (SCM));
-
- /*
- don't worry about write barrier: retvec is new anyway.
- */
- vp = SCM_WRITABLE_VELTS (retvec);
- scm_merge_vector_step (vp,
+ scm_merge_vector_step (retvec,
temp,
scm_cmp_function (less),
less,
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 86dc0b121..947c333be 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -301,7 +301,11 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
SCM_ASSERT_RANGE (5, start2, e-i+j <= SCM_VECTOR_LENGTH (vec2));
while (i<e)
- SCM_VECTOR_SET (vec2, j++, SCM_VELTS (vec1)[i++]);
+ {
+ SCM_VECTOR_SET (vec2, j, SCM_VELTS (vec1)[i]);
+ i++;
+ j++;
+ }
return SCM_UNSPECIFIED;
}
@@ -333,7 +337,12 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
j = e - i + j;
SCM_ASSERT_RANGE (5, start2, j <= SCM_VECTOR_LENGTH (vec2));
while (i < e)
- SCM_VECTOR_SET (vec2, --j, SCM_VELTS (vec1)[--e]);
+ {
+ j--;
+ e--;
+ SCM_VECTOR_SET (vec2, j, SCM_VELTS (vec1)[e]);
+ }
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME