mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-19 18:20:22 +02:00
Code Activity

Merge commit '9b0975f1dc'

Browse source 
Conflicts:
	libguile/foreign.c
	module/ice-9/psyntax-pp.scm
	module/ice-9/psyntax.scm
This commit is contained in:
Andy Wingo 2012-01-30 18:25:07 +01:00
commit 855db1905d
331 changed files with 1929 additions and 817 deletions
Download patch file Download diff file Expand all files Collapse all files

32
libguile/filesys.c
View file

@ -1,5 +1,6 @@
/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
*
/* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004, 2006,
* 2009, 2010, 2011, 2012 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 3 of
@ -96,23 +97,9 @@
#include <pwd.h>
#endif
#include <dirent.h>
#if HAVE_DIRENT_H
# include <dirent.h>
# define NAMLEN(dirent) strlen((dirent)->d_name)
#else
# define dirent direct
# define NAMLEN(dirent) (dirent)->d_namlen
# if HAVE_SYS_NDIR_H
# include <sys/ndir.h>
# endif
# if HAVE_SYS_DIR_H
# include <sys/dir.h>
# endif
# if HAVE_NDIR_H
# include <ndir.h>
# endif
#endif
#define NAMLEN(dirent) strlen ((dirent)->d_name)
/* Some more definitions for the native Windows port. */
#ifdef __MINGW32__
@ -121,15 +108,6 @@
# define fchmod(fd, mode) (-1)
#endif /* __MINGW32__ */
/* dirfd() returns the file descriptor underlying a "DIR*" directory stream.
Found on MacOS X for instance. The following definition is for Solaris
10, it's probably not right elsewhere, but that's ok, it shouldn't be
used elsewhere. Crib note: If we need more then gnulib has a dirfd.m4
figuring out how to get the fd (dirfd function, dirfd macro, dd_fd field,
or d_fd field). */
#ifndef dirfd
#define dirfd(dirstream) ((dirstream)->dd_fd)
#endif

5
libguile/fluids.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 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
@ -179,7 +179,8 @@ scm_make_fluid (void)
SCM_DEFINE (scm_make_fluid_with_default, "make-fluid", 0, 1, 0,
(SCM dflt),
"Return a newly created fluid.\n"
"Return a newly created fluid, whose initial value is @var{dflt},\n"
"or @code{#f} if @var{dflt} is not given.\n"
"Fluids are objects that can hold one\n"
"value per dynamic state. That is, modifications to this value are\n"
"only visible to code that executes with the same dynamic state as\n"

7
libguile/foreign.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2010, 2011 Free Software Foundation, Inc.
/* Copyright (C) 2010, 2011, 2012 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
@ -266,7 +266,8 @@ SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0,
blen = scm_to_size_t (len);
ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype, pointer);
ret = scm_c_take_typed_bytevector ((signed char *) ptr + boffset,
blen, btype, pointer);
return ret;
}
@ -280,7 +281,7 @@ SCM_DEFINE (scm_bytevector_to_pointer, "bytevector->pointer", 1, 1, 0,
#define FUNC_NAME s_scm_bytevector_to_pointer
{
SCM ret;
scm_t_int8 *ptr;
signed char *ptr;
size_t boffset;
SCM_VALIDATE_BYTEVECTOR (1, bv);

10
libguile/i18n.c
View file

@ -1744,13 +1744,23 @@ define_langinfo_items (void)
DEFINE_NLITEM_CONSTANT (T_FMT); /* Time format for strftime. */
DEFINE_NLITEM_CONSTANT (T_FMT_AMPM);/* 12-hour time format for strftime. */
#ifdef ERA
DEFINE_NLITEM_CONSTANT (ERA); /* Alternate era. */
#endif
#ifdef ERA_D_FMT
DEFINE_NLITEM_CONSTANT (ERA_D_FMT); /* Date in alternate era format. */
#endif
#ifdef ERA_D_T_FMT
DEFINE_NLITEM_CONSTANT (ERA_D_T_FMT); /* Date and time in alternate era
format. */
#endif
#ifdef ERA_T_FMT
DEFINE_NLITEM_CONSTANT (ERA_T_FMT); /* Time in alternate era format. */
#endif
#ifdef ALT_DIGITS
DEFINE_NLITEM_CONSTANT (ALT_DIGITS); /* Alternate symbols for digits. */
#endif
DEFINE_NLITEM_CONSTANT (RADIXCHAR);
DEFINE_NLITEM_CONSTANT (THOUSEP);

3
libguile/print.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008,
* 2009, 2010, 2011 Free Software Foundation, Inc.
* 2009, 2010, 2011, 2012 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
@ -654,6 +654,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_array:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_i_print_array (exp, port, pstate);
EXIT_NESTED_DATA (pstate);
break;
case scm_tc7_bytevector:
scm_i_print_bytevector (exp, port, pstate);

85
libguile/strings.c
View file

@ -267,8 +267,22 @@ SCM scm_nullstr;
SCM
scm_i_make_string (size_t len, char **charsp, int read_only_p)
{
SCM buf = make_stringbuf (len);
static SCM null_stringbuf = SCM_BOOL_F;
SCM buf;
SCM res;
if (len == 0)
{
if (SCM_UNLIKELY (scm_is_false (null_stringbuf)))
{
null_stringbuf = make_stringbuf (0);
SET_STRINGBUF_SHARED (null_stringbuf);
}
buf = null_stringbuf;
}
else
buf = make_stringbuf (len);
if (charsp)
*charsp = (char *) STRINGBUF_CHARS (buf);
res = scm_double_cell (read_only_p ? RO_STRING_TAG : STRING_TAG,
@ -320,37 +334,48 @@ get_str_buf_start (SCM *str, SCM *buf, size_t *start)
SCM
scm_i_substring (SCM str, size_t start, size_t end)
{
SCM buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
(scm_t_bits)str_start + start,
(scm_t_bits) end - start);
if (start == end)
return scm_i_make_string (0, NULL, 0);
else
{
SCM buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
(scm_t_bits)str_start + start,
(scm_t_bits) end - start);
}
}
SCM
scm_i_substring_read_only (SCM str, size_t start, size_t end)
{
SCM buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf),
(scm_t_bits)str_start + start,
(scm_t_bits) end - start);
if (start == end)
return scm_i_make_string (0, NULL, 1);
else
{
SCM buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf),
(scm_t_bits)str_start + start,
(scm_t_bits) end - start);
}
}
SCM
scm_i_substring_copy (SCM str, size_t start, size_t end)
{
size_t len = end - start;
SCM buf, my_buf;
SCM buf, my_buf, substr;
size_t str_start;
int wide = 0;
get_str_buf_start (&str, &buf, &str_start);
if (scm_i_is_narrow_string (str))
{
@ -364,12 +389,14 @@ scm_i_substring_copy (SCM str, size_t start, size_t end)
u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (my_buf),
(scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf) + str_start
+ start), len);
/* Even though this string is wide, the substring may be narrow.
Consider adding code to narrow the string. */
wide = 1;
}
scm_remember_upto_here_1 (buf);
return scm_double_cell (STRING_TAG, SCM_UNPACK (my_buf),
(scm_t_bits) 0, (scm_t_bits) len);
substr = scm_double_cell (STRING_TAG, SCM_UNPACK (my_buf),
(scm_t_bits) 0, (scm_t_bits) len);
if (wide)
scm_i_try_narrow_string (substr);
return substr;
}
SCM
@ -377,7 +404,9 @@ scm_i_substring_shared (SCM str, size_t start, size_t end)
{
if (start == 0 && end == STRING_LENGTH (str))
return str;
else
else if (start == end)
return scm_i_make_string (0, NULL, 0);
else
{
size_t len = end - start;
if (IS_SH_STRING (str))
@ -1489,12 +1518,10 @@ scm_from_stringn (const char *str, size_t len, const char *encoding,
scm_misc_error ("scm_from_stringn", "NULL string pointer", SCM_EOL);
if (len == (size_t) -1)
len = strlen (str);
if (len == 0)
return scm_nullstr;
if (encoding == NULL)
if (encoding == NULL || len == 0)
{
/* If encoding is null, use Latin-1. */
/* If encoding is null (or the string is empty), use Latin-1. */
char *buf;
res = scm_i_make_string (len, &buf, 0);
memcpy (buf, str, len);

4
libguile/threads.c
View file

@ -550,7 +550,7 @@ guilify_self_1 (struct GC_stack_base *base)
t.critical_section_level = 0;
t.base = base->mem_base;
#ifdef __ia64__
t.register_backing_store_base = base->reg-base;
t.register_backing_store_base = base->reg_base;
#endif
t.continuation_root = SCM_EOL;
t.continuation_base = t.base;
@ -1127,6 +1127,8 @@ scm_spawn_thread (scm_t_catch_body body, void *body_data,
scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
scm_i_pthread_mutex_unlock (&data.mutex);
assert (SCM_I_IS_THREAD (data.thread));
return data.thread;
}

25
libguile/values.c
View file

@ -67,6 +67,31 @@ print_values (SCM obj, SCM pwps)
return SCM_UNSPECIFIED;
}
SCM
scm_c_value_ref (SCM obj, size_t idx)
{
if (SCM_LIKELY (SCM_VALUESP (obj)))
{
SCM values = scm_struct_ref (obj, SCM_INUM0);
size_t i = idx;
while (SCM_LIKELY (scm_is_pair (values)))
{
if (i == 0)
return SCM_CAR (values);
values = SCM_CDR (values);
i--;
}
}
else if (idx == 0)
return obj;
scm_error (scm_out_of_range_key,
"scm_c_value_ref",
"Too few values in ~S to access index ~S",
scm_list_2 (obj, scm_from_unsigned_integer (idx)),
scm_list_1 (scm_from_unsigned_integer (idx)));
}
SCM_DEFINE (scm_values, "values", 0, 0, 1,
(SCM args),
"Delivers all of its arguments to its continuation. Except for\n"

1
libguile/values.h
View file

@ -33,6 +33,7 @@ SCM_API SCM scm_values_vtable;
SCM_INTERNAL void scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2);
SCM_API SCM scm_values (SCM args);
SCM_API SCM scm_c_value_ref (SCM values, size_t idx);
SCM_INTERNAL void scm_init_values (void);
#endif /* SCM_VALUES_H */