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

Merge branch 'master' into boehm-demers-weiser-gc

Browse source 
Conflicts:
	libguile/Makefile.am
	libguile/threads.c
This commit is contained in:
Ludovic Courtès 2008-10-11 19:25:54 +02:00
commit 074f69cdf2
29 changed files with 64 additions and 3238 deletions
Download patch file Download diff file Expand all files Collapse all files

5
NEWS
View file

@ -32,6 +32,8 @@ See `cancel-thread', `set-thread-cleanup!', and `thread-cleanup'.
* Changes to the C interface * Changes to the C interface
** The GH interface (deprecated in version 1.6, 2001) was removed.
** Internal `scm_i_' functions now have "hidden" linkage with GCC/ELF ** Internal `scm_i_' functions now have "hidden" linkage with GCC/ELF
This makes these internal functions technically not callable from This makes these internal functions technically not callable from
@ -64,13 +66,14 @@ available: Guile is now always configured in "maintainer mode".
* Bugs fixed * Bugs fixed
** `symbol->string' now returns a read-only string, as per R5RS ** `symbol->string' now returns a read-only string, as per R5RS
** Literal strings as returned by `read' are now read-only, as per R5RS ** Fix incorrect handling of the FLAGS argument of `fold-matches'
** `guile-config link' now prints `-L$libdir' before `-lguile' ** `guile-config link' now prints `-L$libdir' before `-lguile'
** Fix memory corruption involving GOOPS' `class-redefinition' ** Fix memory corruption involving GOOPS' `class-redefinition'
** Fix possible deadlock in `mutex-lock' ** Fix possible deadlock in `mutex-lock'
** Fix build issue on Tru64 and ia64-hp-hpux11.23 (`SCM_UNPACK' macro) ** Fix build issue on Tru64 and ia64-hp-hpux11.23 (`SCM_UNPACK' macro)
** Fix build issue on mips, mipsel, powerpc and ia64 (stack direction) ** Fix build issue on mips, mipsel, powerpc and ia64 (stack direction)
** Fix build issue on hppa2.0w-hp-hpux11.11 (`dirent64' and `readdir64_r') ** Fix build issue on hppa2.0w-hp-hpux11.11 (`dirent64' and `readdir64_r')
** Fix build issue on i386-unknown-freebsd7.0 ("break strict-aliasing rules")
** Fix misleading output from `(help rationalize)' ** Fix misleading output from `(help rationalize)'
** Fix build failure on Debian hppa architecture (bad stack growth detection) ** Fix build failure on Debian hppa architecture (bad stack growth detection)
** Fix `gcd' when called with a single, negative argument. ** Fix `gcd' when called with a single, negative argument.

2
doc/goops/Makefile.am
View file

@ -26,6 +26,4 @@ info_TEXINFOS = goops.texi
goops_TEXINFOS = goops-tutorial.texi \ goops_TEXINFOS = goops-tutorial.texi \
hierarchy.eps hierarchy.png hierarchy.txt hierarchy.pdf hierarchy.eps hierarchy.png hierarchy.txt hierarchy.pdf
TEXINFO_TEX = ../ref/texinfo.tex
EXTRA_DIST = ChangeLog-2008 EXTRA_DIST = ChangeLog-2008

2
doc/r5rs/Makefile.am
View file

@ -23,6 +23,4 @@ AUTOMAKE_OPTIONS = gnu
info_TEXINFOS = r5rs.texi info_TEXINFOS = r5rs.texi
TEXINFO_TEX = ../ref/texinfo.tex
EXTRA_DIST = ChangeLog-2008 EXTRA_DIST = ChangeLog-2008

1
doc/ref/Makefile.am
View file

@ -55,7 +55,6 @@ guile_TEXINFOS = preface.texi \
scsh.texi \ scsh.texi \
tcltk.texi \ tcltk.texi \
scheme-scripts.texi \ scheme-scripts.texi \
gh.texi \
api-overview.texi \ api-overview.texi \
scheme-debugging.texi \ scheme-debugging.texi \
scheme-using.texi \ scheme-using.texi \

1201
doc/ref/gh.texi
View file

File diff suppressed because it is too large Load diff

2
doc/ref/guile.texi
View file

@ -307,7 +307,6 @@ available through both Scheme and C interfaces.
* Translation:: Support for translating other languages. * Translation:: Support for translating other languages.
* Internationalization:: Support for gettext, etc. * Internationalization:: Support for gettext, etc.
* Debugging:: Debugging infrastructure and Scheme interface. * Debugging:: Debugging infrastructure and Scheme interface.
* GH:: The deprecated GH interface.
@end menu @end menu
@include api-overview.texi @include api-overview.texi
@ -331,7 +330,6 @@ available through both Scheme and C interfaces.
@include api-translation.texi @include api-translation.texi
@include api-i18n.texi @include api-i18n.texi
@include api-debug.texi @include api-debug.texi
@include gh.texi
@node Guile Modules @node Guile Modules
@chapter Guile Modules @chapter Guile Modules

2
doc/tutorial/Makefile.am
View file

@ -23,6 +23,4 @@ AUTOMAKE_OPTIONS = gnu
info_TEXINFOS = guile-tut.texi info_TEXINFOS = guile-tut.texi
TEXINFO_TEX = ../ref/texinfo.tex
EXTRA_DIST = ChangeLog-2008 EXTRA_DIST = ChangeLog-2008

1
guile-readline/readline.c
View file

@ -27,7 +27,6 @@
#ifdef HAVE_RL_GETC_FUNCTION #ifdef HAVE_RL_GETC_FUNCTION
#include "libguile.h" #include "libguile.h"
#include "libguile/gh.h"
#include "libguile/iselect.h" #include "libguile/iselect.h"
#include <stdio.h> #include <stdio.h>

4
ice-9/regex.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1997, 1999, 2001, 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; Copyright (C) 1997, 1999, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -178,7 +178,7 @@
(define (fold-matches regexp string init proc . flags) (define (fold-matches regexp string init proc . flags)
(let ((regexp (if (regexp? regexp) regexp (make-regexp regexp))) (let ((regexp (if (regexp? regexp) regexp (make-regexp regexp)))
(flags (if (null? flags) 0 flags))) (flags (if (null? flags) 0 (car flags))))
(let loop ((start 0) (let loop ((start 0)
(value init) (value init)
(abuts #f)) ; True if start abuts a previous match. (abuts #f)) ; True if start abuts a previous match.

256
libguile/ChangeLog-gh
View file

@ -1,256 +0,0 @@
The gh implementation (gh_data.c, gh.h, etc.) used to live in a
separate directory called gh. In April 1997, that dir was merged with
libguile; this is the ChangeLog from the old directory.
Please put new entries in the ordinary ChangeLog.
Thu Apr 10 16:14:43 1997 Jim Blandy <jimb@floss.cyclic.com>
Let the test programs build even when we're not using threads.
* configure.in: Use CY_AC_WITH_THREADS to decide whether to build
with threads.
* Makefile.am (check_PROGRAMS_LDADD): Remove -lthreads -lqt. The
configure script will stick them in LIBS if they're needed.
* Makefile.in, aclocal.m4, configure: Rebuilt.
* gh_funcs.c (gh_apply, gh_call0, gh_call1, gh_call2, gh_call3):
New functions.
* gh.h: Prototypes for above.
* gh_test_c.c (main_prog): Added test cases for above.
* gh.h (gh_display, gh_newline): Added prototypes.
* gh_test_c.c (main_prog): Remove bizarre single quote from test
of gh_symbol2scm, and from "test" of (display "hello world").
* gh.c: Removed; its guts have been redistributed to the other
gh-mumble.c files.
* gh.c, gh_data.c, gh_eval.c, gh_funcs.c, gh_init.c, gh_io.c,
gh_list.c, gh_predicates.c, gh_test_c.c, gh_test_repl.c:
Re-indented, according to the GNU coding standards. (Put function
names at beginning of lines, basically.)
Wed Apr 9 17:56:34 1997 Jim Blandy <jimb@floss.cyclic.com>
Changes to work with automake-1.1n, which has better libtool support.
* Makefile.am: Use lib_LTLIBRARIES, not lib_PROGRAMS.
* Makefile.in: Regenerated.
Sat Mar 8 06:37:23 1997 Gary Houston <ghouston@actrix.gen.nz>
* gh_eval.c (gh_eval_file): remove case_i, sharp arguments from
scm_primitive_load call.
Mon Feb 24 21:45:32 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
* configure.in: Added AM_MAINTAINER_MODE
Wed Feb 12 16:34:42 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
* gh_data.c (gh_symbol2newstr): added this conversion from SCM
symbol to C string.
(gh_set_substr): more data conversion: from part of a (possibly
large) C string to an existing SCM string.
(gh_get_substr): more data conversion: from part of a (possibly
large) SCM string to an existing C char array.
Mon Feb 10 14:03:09 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
* gh_funcs.c (gh_define): added this function.
* gh_init.c (gh_catch): fixed stupid bug, gh_catch() was not
returning anything.
* gh_data.c (gh_scm2newstr): Renamed gh_scm2str0() to
gh_scm2newstr(), and did away with the str0 convention (it doesn't
seem to belong in gh_).
(gh_scm2str): this function now copies Scheme data to a
pre-allocated C string.
Fri Feb 7 15:12:30 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
* gh_data.c (gh_scm2str0): On Sascha Ziemann and Jim Blandy's
suggestion I changed gh_scm2str0() so that it returns a malloc-ed
string, rather than taking a pre-allocated string with a maximum
length...
Fri Jan 24 08:18:28 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
* gh_eval.c (gh_eval_str): gh_eval_str() now returns an SCM object
with the result of the evaluation. It has also been simplified to
just call scm_eval_0str(). gh_eval_file() has been similarly
altered.
Sat Jan 11 14:40:17 1997 Marius Vollmer <mvo@zagadka.ping.de>
* ltconfig, ltmain.sh: New files for libtool support. libguile,
rx, gh and gtcltk-lib can now be build as shared libraries.
* Makefile.am (EXTRA_DIST): Added ltconfig and ltmain.sh
Sun Jan 5 16:57:10 1997 Jim Blandy <jimb@floss.cyclic.com>
* Guile 1.0 released. This is the first release by the Free
Software Foundation; Cygnus has also released earlier versions of
Guile.
* GUILE-VERSION: Updated version number.
* NEWS: Added comments for all the user-visible changes marked in
the ChangeLogs.
* README: Updated for release.
Thu Dec 12 00:14:32 1996 Gary Houston <ghouston@actrix.gen.nz>
* scsh: new directory.
Mon Dec 2 17:33:04 1996 Tom Tromey <tromey@cygnus.com>
* configure.in: Generate doc/guile-programmer/Makefile and
doc/guile-user/Makefile.
Sat Nov 30 23:45:54 1996 Tom Tromey <tromey@cygnus.com>
* aclocal.m4: Now automatically generated by aclocal.
* threads.m4: New file.
* guile.m4: New file.
* Makefile.am, doc/Makefile.am: New files.
* configure.in: Updated for Automake. Avoid excessively verbose
"greet" messages.
Wed Oct 16 07:32:14 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
* lgh: directory renamed to gh, along with all prefixes of the
high level library procedures.
Thu Oct 10 14:37:43 1996 Jim Blandy <jimb@floss.cyclic.com>
* Makefile.in (TAGS tags): Find the source files in $srcdir.
Wed Oct 9 19:37:14 1996 Jim Blandy <jimb@floss.cyclic.com>
* Makefile.in (DISTFILES): Add AUTHORS and aclocal.m4.
Tue Oct 1 00:13:55 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
* configure.in: Added some configuration magic from the Cygnus
distribution.
* aclocal.m4: New file. For now used for thread support
configuration.
Fri Sep 13 14:39:30 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
* Makefile.in (DISTFILES): added mkinstalldirs to the DISTFILES
* PLUGIN: changed the PLUGIN/REQ files in the ice-9 and lgh
directories, to arrange for lgh to the last thing
configured/built.
Wed Sep 11 21:11:33 1996 Mark Galassi <rosalia@nis.lanl.gov>
* lgh/: added the directory in which I implement the high level
libguile library (lgh_) for this release of Guile. See the
ChangeLog in there for further details.
Wed Sep 11 16:12:53 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
* doc/ (guile-user and guile-programmer): added the guile-user and
guile-programmer directories which contain the user and programmer
manuals. See the ChangeLog entries there for detail.
Wed Sep 11 14:33:49 1996 Jim Blandy <jimb@floss.cyclic.com>
* Makefile.in (distclean): Don't forget to delete doc/Makefile.
* Makefile.in (distclean): Don't forget to delete
config.build-subdirs.
Thu Sep 5 17:36:15 1996 Jim Blandy <jimb@floss.cyclic.com>
* Makefile.in (tags): New name for `TAGS' target, which will
always run the commands.
Thu Sep 5 09:56:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
* README: Doc fixes.
Fri Aug 30 16:56:27 1996 Jim Blandy <jimb@floss.cyclic.com>
* Makefile.in (TAGS): Produce a single tags file for all of Guile.
Thu Aug 15 19:03:03 1996 Jim Blandy <jimb@floss.cyclic.com>
* configure.in: Check for -ldl, so the check for Tcl won't fail
spuriously.
Thu Aug 15 01:29:29 1996 Jim Blandy <jimb@totoro.cyclic.com>
Change the way we decide whether to build gtcltk-lib, so that it's
omitted from the build process when appropriate, but never from
the dist process.
* configure.in: Don't edit all_subdirs depending on the
availability of Tk; let that be the list of all PLUGIN
subdirectories present, as it used to be. Instead, edit a new
variable, build_subdirs; write its final value, the list of
subdirs we do want to compile in, to config.build-subdirs.
Substitute that into the top-level Makefile too.
* Makefile.in (subdirs): Set this to @build_subdirs@, so we only
recurse on the subdirectories we should build.
(distdirs): Set this to @existingdirs@, so it includes the subdirs
we decided not to build.
* doc/gtcltk.texi: File resurrected from old Guile releases.
* doc/Makefile.in (info): Build the gtcltk documentation.
(DIST_FILES): Include it in the distribution.
* configure.in: If we can find the library for tcl7.5, build
gtcltk-lib. Call AC_PROG_CC, to help run that test with the right
compiler (not sure this is necessary).
Mon Aug 12 15:09:37 1996 Jim Blandy <jimb@totoro.cyclic.com>
* NEWS: Fix bug reporting address.
Fri Aug 9 15:58:42 1996 Jim Blandy <jimb@totoro.cyclic.com>
* AUTHORS: New file, in accordance with the GNU maintainers'
standards.
Tue Aug 6 14:40:44 1996 Jim Blandy <jimb@totoro.cyclic.com>
* README: Renamed from ANNOUNCE; include bug report address,
description, and short tour.
* INSTALL: Renamed from BUILDING.
* NEWS: New file.
* Makefile.in (DISTFILES): Update appropriately.
Thu Aug 1 02:31:53 1996 Jim Blandy <jimb@totoro.cyclic.com>
* doc/Makefile.in: Added pattern targets for creating DVI and
PostScript files.
(%.ps, %.dvi, %.txt): New targets.
(DVIPS, TEXI2DVI): New variables.
* GUILE-VERSION: Updated to 1.0b3.
Rehashed distribution system, in preparation for nightly
snapshots. Other changes in subdirectories.
* Makefile.in (dist): Rewritten --- the old target was out of
date, dependent on files that we don't have, and relied on GNU
tar. The new target is simpler.
(VERSION, srcdir, dist_dirs): New variables.
(DISTFILES): Renamed from localfiles. Added GUILE-VERSION and
TODO.
(localtreats): Variable removed. We don't have this file.
(info): cd to doc and make info there; don't make info in every
${subdir}; those Makefiles don't know what to do.
(distname, distdir, treats, announcefile): Variables removed.
(manifest-file): Target removed.
(dist-dir): New target, responsible for distributable files in
this directory.
(GZIP, GZIP_EXT, TAR_VERBOSE, DIST_NAME): New variables,
controlling the 'dist' target.
* configure.in: Substitute GUILE-VERSION into the top-level
Makefile. Build doc/Makefile from doc/Makefile.in.
* doc/Makefile.in: New file.

7
libguile/Makefile.am
View file

@ -110,8 +110,7 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
deprecated.c discouraged.c dynwind.c eq.c error.c \ deprecated.c discouraged.c dynwind.c eq.c error.c \
eval.c evalext.c extensions.c feature.c fluids.c fports.c \ eval.c evalext.c extensions.c feature.c fluids.c fports.c \
futures.c gc.c gc-malloc.c \ futures.c gc.c gc-malloc.c \
gdbint.c gettext.c gh_data.c gh_eval.c gh_funcs.c \ gdbint.c gettext.c goops.c gsubr.c \
gh_init.c gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c \
guardians.c hash.c hashtab.c hooks.c init.c inline.c \ guardians.c hash.c hashtab.c hooks.c init.c inline.c \
ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \ ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \
modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \ modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \
@ -202,7 +201,7 @@ libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library)
libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined
# These are headers visible as <guile/mumble.h> # These are headers visible as <guile/mumble.h>
pkginclude_HEADERS = gh.h pkginclude_HEADERS =
# These are headers visible as <libguile/mumble.h>. # These are headers visible as <libguile/mumble.h>.
modincludedir = $(includedir)/libguile modincludedir = $(includedir)/libguile
@ -233,7 +232,7 @@ bin_SCRIPTS = guile-snarf
# and people feel like maintaining them. For now, this is not the case. # and people feel like maintaining them. For now, this is not the case.
noinst_SCRIPTS = guile-doc-snarf guile-snarf-docs guile-func-name-check noinst_SCRIPTS = guile-doc-snarf guile-snarf-docs guile-func-name-check
EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \ EXTRA_DIST = ChangeLog-scm ChangeLog-threads \
ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 cpp_signal.c \ ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 cpp_signal.c \
cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \ cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \
cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \ cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \

1
libguile/environments.c
View file

@ -23,7 +23,6 @@
#include "libguile/_scm.h" #include "libguile/_scm.h"
#include "libguile/alist.h" #include "libguile/alist.h"
#include "libguile/eval.h" #include "libguile/eval.h"
#include "libguile/gh.h"
#include "libguile/hash.h" #include "libguile/hash.h"
#include "libguile/list.h" #include "libguile/list.h"
#include "libguile/ports.h" #include "libguile/ports.h"

243
libguile/gh.h
View file

@ -1,243 +0,0 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifndef __GH_H
#define __GH_H
/* This needs to be included outside of the extern "C" block.
*/
#include <libguile.h>
#if SCM_ENABLE_DEPRECATED
#ifdef __cplusplus
extern "C" {
#endif
/* gcc has extern inline functions that are basically as fast as macros */
#ifdef __GNUC__
# define INL inline
# define EXTINL extern inline
#else
# define INL
#define EXTINL
#endif /* __GNUC__ */
SCM_API void gh_enter(int argc, char *argv[],
void (*c_main_prog)(int, char **));
#define gh_init () scm_init_guile ()
SCM_API void gh_repl(int argc, char *argv[]);
SCM_API SCM gh_catch(SCM tag, scm_t_catch_body body, void *body_data,
scm_t_catch_handler handler, void *handler_data);
SCM_API SCM gh_standard_handler(void *data, SCM tag, SCM throw_args);
SCM_API SCM gh_eval_str(const char *scheme_code);
SCM_API SCM gh_eval_str_with_catch(const char *scheme_code, scm_t_catch_handler handler);
SCM_API SCM gh_eval_str_with_standard_handler(const char *scheme_code);
SCM_API SCM gh_eval_str_with_stack_saving_handler(const char *scheme_code);
SCM_API SCM gh_eval_file(const char *fname);
#define gh_load(fname) gh_eval_file(fname)
SCM_API SCM gh_eval_file_with_catch(const char *scheme_code, scm_t_catch_handler handler);
SCM_API SCM gh_eval_file_with_standard_handler(const char *scheme_code);
#define gh_defer_ints() SCM_CRITICAL_SECTION_START
#define gh_allow_ints() SCM_CRITICAL_SECTION_END
SCM_API SCM gh_new_procedure(const char *proc_name, SCM (*fn)(),
int n_required_args, int n_optional_args,
int varp);
SCM_API SCM gh_new_procedure0_0(const char *proc_name, SCM (*fn)(void));
SCM_API SCM gh_new_procedure0_1(const char *proc_name, SCM (*fn)(SCM));
SCM_API SCM gh_new_procedure0_2(const char *proc_name, SCM (*fn)(SCM, SCM));
SCM_API SCM gh_new_procedure1_0(const char *proc_name, SCM (*fn)(SCM));
SCM_API SCM gh_new_procedure1_1(const char *proc_name, SCM (*fn)(SCM, SCM));
SCM_API SCM gh_new_procedure1_2(const char *proc_name, SCM (*fn)(SCM, SCM, SCM));
SCM_API SCM gh_new_procedure2_0(const char *proc_name, SCM (*fn)(SCM, SCM));
SCM_API SCM gh_new_procedure2_1(const char *proc_name, SCM (*fn)(SCM, SCM, SCM));
SCM_API SCM gh_new_procedure2_2(const char *proc_name, SCM (*fn)(SCM, SCM, SCM, SCM));
SCM_API SCM gh_new_procedure3_0(const char *proc_name, SCM (*fn)(SCM, SCM, SCM));
SCM_API SCM gh_new_procedure4_0(const char *proc_name, SCM (*fn)(SCM, SCM, SCM, SCM));
SCM_API SCM gh_new_procedure5_0(const char *proc_name, SCM (*fn)(SCM, SCM, SCM, SCM, SCM));
/* C to Scheme conversion */
SCM_API SCM gh_bool2scm(int x);
SCM_API SCM gh_int2scm(int x);
SCM_API SCM gh_ulong2scm(unsigned long x);
SCM_API SCM gh_long2scm(long x);
SCM_API SCM gh_double2scm(double x);
SCM_API SCM gh_char2scm(char c);
SCM_API SCM gh_str2scm(const char *s, size_t len);
SCM_API SCM gh_str02scm(const char *s);
SCM_API void gh_set_substr(const char *src, SCM dst, long start, size_t len);
SCM_API SCM gh_symbol2scm(const char *symbol_str);
SCM_API SCM gh_ints2scm(const int *d, long n);
SCM_API SCM gh_chars2byvect(const char *d, long n);
SCM_API SCM gh_shorts2svect(const short *d, long n);
SCM_API SCM gh_longs2ivect(const long *d, long n);
SCM_API SCM gh_ulongs2uvect(const unsigned long *d, long n);
SCM_API SCM gh_floats2fvect(const float *d, long n);
SCM_API SCM gh_doubles2dvect(const double *d, long n);
SCM_API SCM gh_doubles2scm(const double *d, long n);
/* Scheme to C conversion */
SCM_API int gh_scm2bool(SCM obj);
SCM_API int gh_scm2int(SCM obj);
SCM_API unsigned long gh_scm2ulong(SCM obj);
SCM_API long gh_scm2long(SCM obj);
SCM_API char gh_scm2char(SCM obj);
SCM_API double gh_scm2double(SCM obj);
SCM_API char *gh_scm2newstr(SCM str, size_t *lenp);
SCM_API void gh_get_substr(SCM src, char *dst, long start, size_t len);
SCM_API char *gh_symbol2newstr(SCM sym, size_t *lenp);
SCM_API char *gh_scm2chars(SCM vector, char *result);
SCM_API short *gh_scm2shorts(SCM vector, short *result);
SCM_API long *gh_scm2longs(SCM vector, long *result);
SCM_API float *gh_scm2floats(SCM vector, float *result);
SCM_API double *gh_scm2doubles(SCM vector, double *result);
/* type predicates: tell you if an SCM object has a given type */
SCM_API int gh_boolean_p(SCM val);
SCM_API int gh_symbol_p(SCM val);
SCM_API int gh_char_p(SCM val);
SCM_API int gh_vector_p(SCM val);
SCM_API int gh_pair_p(SCM val);
SCM_API int gh_number_p(SCM val);
SCM_API int gh_string_p(SCM val);
SCM_API int gh_procedure_p(SCM val);
SCM_API int gh_list_p(SCM val);
SCM_API int gh_inexact_p(SCM val);
SCM_API int gh_exact_p(SCM val);
/* more predicates */
SCM_API int gh_eq_p(SCM x, SCM y);
SCM_API int gh_eqv_p(SCM x, SCM y);
SCM_API int gh_equal_p(SCM x, SCM y);
SCM_API int gh_string_equal_p(SCM s1, SCM s2);
SCM_API int gh_null_p(SCM l);
/* standard Scheme procedures available from C */
#define gh_not(x) scm_not(x)
SCM_API SCM gh_define(const char *name, SCM val);
/* string manipulation routines */
#define gh_make_string(k, chr) scm_make_string(k, chr)
#define gh_string_length(str) scm_string_length(str)
#define gh_string_ref(str, k) scm_string_ref(str, k)
#define gh_string_set_x(str, k, chr) scm_string_set_x(str, k, chr)
#define gh_substring(str, start, end) scm_substring(str, start, end)
#define gh_string_append(args) scm_string_append(args)
/* vector manipulation routines */
/* note that gh_vector() does not behave quite like the Scheme (vector
obj1 obj2 ...), because the interpreter engine does not pass the
data element by element, but rather as a list. thus, gh_vector()
ends up being identical to gh_list_to_vector() */
#define gh_vector(ls) scm_vector(ls)
SCM_API SCM gh_make_vector(SCM length, SCM val);
SCM_API SCM gh_vector_set_x(SCM vec, SCM pos, SCM val);
SCM_API SCM gh_vector_ref(SCM vec, SCM pos);
SCM_API unsigned long gh_vector_length (SCM v);
SCM_API unsigned long gh_uniform_vector_length (SCM v);
SCM_API SCM gh_uniform_vector_ref (SCM v, SCM ilist);
#define gh_list_to_vector(ls) scm_vector(ls)
#define gh_vector_to_list(v) scm_vector_to_list(v)
SCM_API SCM gh_lookup (const char *sname);
SCM_API SCM gh_module_lookup (SCM module, const char *sname);
SCM_API SCM gh_cons(SCM x, SCM y);
#define gh_list scm_list_n
SCM_API unsigned long gh_length(SCM l);
SCM_API SCM gh_append(SCM args);
SCM_API SCM gh_append2(SCM l1, SCM l2);
SCM_API SCM gh_append3(SCM l1, SCM l2, SCM l3);
SCM_API SCM gh_append4(SCM l1, SCM l2, SCM l3, SCM l4);
#define gh_reverse(ls) scm_reverse(ls)
#define gh_list_tail(ls, k) scm_list_tail(ls, k)
#define gh_list_ref(ls, k) scm_list_ref(ls, k)
#define gh_memq(x, ls) scm_memq(x, ls)
#define gh_memv(x, ls) scm_memv(x, ls)
#define gh_member(x, ls) scm_member(x, ls)
#define gh_assq(x, alist) scm_assq(x, alist)
#define gh_assv(x, alist) scm_assv(x, alist)
#define gh_assoc(x, alist) scm_assoc(x, alist)
SCM_API SCM gh_car(SCM x);
SCM_API SCM gh_cdr(SCM x);
SCM_API SCM gh_caar(SCM x);
SCM_API SCM gh_cadr(SCM x);
SCM_API SCM gh_cdar(SCM x);
SCM_API SCM gh_cddr(SCM x);
SCM_API SCM gh_caaar(SCM x);
SCM_API SCM gh_caadr(SCM x);
SCM_API SCM gh_cadar(SCM x);
SCM_API SCM gh_caddr(SCM x);
SCM_API SCM gh_cdaar(SCM x);
SCM_API SCM gh_cdadr(SCM x);
SCM_API SCM gh_cddar(SCM x);
SCM_API SCM gh_cdddr(SCM x);
SCM_API SCM gh_set_car_x(SCM pair, SCM value);
SCM_API SCM gh_set_cdr_x(SCM pair, SCM value);
/* Calling Scheme functions from C. */
SCM_API SCM gh_apply (SCM proc, SCM ls);
SCM_API SCM gh_call0 (SCM proc);
SCM_API SCM gh_call1 (SCM proc, SCM arg);
SCM_API SCM gh_call2 (SCM proc, SCM arg1, SCM arg2);
SCM_API SCM gh_call3 (SCM proc, SCM arg1, SCM arg2, SCM arg3);
/* reading and writing Scheme objects. */
SCM_API void gh_display (SCM x);
SCM_API void gh_write (SCM x);
SCM_API void gh_newline (void);
/* void gh_gc_mark(SCM) : mark an SCM as in use. */
/* void gh_defer_ints() : don't interrupt code section. */
/* void gh_allow_ints() : see gh_defer_ints(). */
/* void gh_new_cell(SCM, int tag) : initialize SCM to be of type 'tag' */
/* int gh_type_p(SCM, tag) : test if SCM is of type 'tag' */
/* SCM gh_intern(char*) : get symbol corresponding to c-string.*/
/* void gh_set_ext_data(SCM, void*) : set extension data on SCM */
/* void *gh_get_ext_data(SCM) : return extension data from SCM. */
/* void gh_assert(int cond, char *msg, SCM obj); */
#ifdef __cplusplus
}
#endif
#endif
#endif /* __GH_H */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

659
libguile/gh_data.c
View file

@ -1,659 +0,0 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2004, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
/* data initialization and C<->Scheme data conversion */
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include "libguile/gh.h"
#ifdef HAVE_STRING_H
#include <string.h>
#endif
#include <assert.h>
#if SCM_ENABLE_DEPRECATED
/* data conversion C->scheme */
SCM
gh_bool2scm (int x)
{
return scm_from_bool(x);
}
SCM
gh_int2scm (int x)
{
return scm_from_long ((long) x);
}
SCM
gh_ulong2scm (unsigned long x)
{
return scm_from_ulong (x);
}
SCM
gh_long2scm (long x)
{
return scm_from_long (x);
}
SCM
gh_double2scm (double x)
{
return scm_from_double (x);
}
SCM
gh_char2scm (char c)
{
return SCM_MAKE_CHAR (c);
}
SCM
gh_str2scm (const char *s, size_t len)
{
return scm_from_locale_stringn (s, len);
}
SCM
gh_str02scm (const char *s)
{
return scm_from_locale_string (s);
}
/* Copy LEN characters at SRC into the *existing* Scheme string DST,
starting at START. START is an index into DST; zero means the
beginning of the string.
If START + LEN is off the end of DST, signal an out-of-range
error. */
void
gh_set_substr (const char *src, SCM dst, long start, size_t len)
{
char *dst_ptr;
size_t dst_len;
SCM_ASSERT (scm_is_string (dst), dst, SCM_ARG3, "gh_set_substr");
dst_len = scm_i_string_length (dst);
SCM_ASSERT (start + len <= dst_len, dst, SCM_ARG4, "gh_set_substr");
dst_ptr = scm_i_string_writable_chars (dst);
memmove (dst_ptr + start, src, len);
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (dst);
}
/* Return the symbol named SYMBOL_STR. */
SCM
gh_symbol2scm (const char *symbol_str)
{
return scm_from_locale_symbol(symbol_str);
}
SCM
gh_ints2scm (const int *d, long n)
{
long i;
SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
for (i = 0; i < n; ++i)
SCM_SIMPLE_VECTOR_SET (v, i, scm_from_int (d[i]));
return v;
}
SCM
gh_doubles2scm (const double *d, long n)
{
long i;
SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
for(i = 0; i < n; i++)
SCM_SIMPLE_VECTOR_SET (v, i, scm_from_double (d[i]));
return v;
}
SCM
gh_chars2byvect (const char *d, long n)
{
char *m = scm_malloc (n);
memcpy (m, d, n * sizeof (char));
return scm_take_s8vector ((scm_t_int8 *)m, n);
}
SCM
gh_shorts2svect (const short *d, long n)
{
char *m = scm_malloc (n * sizeof (short));
memcpy (m, d, n * sizeof (short));
assert (sizeof (scm_t_int16) == sizeof (short));
return scm_take_s16vector ((scm_t_int16 *)m, n);
}
SCM
gh_longs2ivect (const long *d, long n)
{
char *m = scm_malloc (n * sizeof (long));
memcpy (m, d, n * sizeof (long));
assert (sizeof (scm_t_int32) == sizeof (long));
return scm_take_s32vector ((scm_t_int32 *)m, n);
}
SCM
gh_ulongs2uvect (const unsigned long *d, long n)
{
char *m = scm_malloc (n * sizeof (unsigned long));
memcpy (m, d, n * sizeof (unsigned long));
assert (sizeof (scm_t_uint32) == sizeof (unsigned long));
return scm_take_u32vector ((scm_t_uint32 *)m, n);
}
SCM
gh_floats2fvect (const float *d, long n)
{
char *m = scm_malloc (n * sizeof (float));
memcpy (m, d, n * sizeof (float));
return scm_take_f32vector ((float *)m, n);
}
SCM
gh_doubles2dvect (const double *d, long n)
{
char *m = scm_malloc (n * sizeof (double));
memcpy (m, d, n * sizeof (double));
return scm_take_f64vector ((double *)m, n);
}
/* data conversion scheme->C */
int
gh_scm2bool (SCM obj)
{
return (scm_is_false (obj)) ? 0 : 1;
}
unsigned long
gh_scm2ulong (SCM obj)
{
return scm_to_ulong (obj);
}
long
gh_scm2long (SCM obj)
{
return scm_to_long (obj);
}
int
gh_scm2int (SCM obj)
{
return scm_to_int (obj);
}
double
gh_scm2double (SCM obj)
{
return scm_to_double (obj);
}
char
gh_scm2char (SCM obj)
#define FUNC_NAME "gh_scm2char"
{
SCM_VALIDATE_CHAR (SCM_ARG1, obj);
return SCM_CHAR (obj);
}
#undef FUNC_NAME
/* Convert a vector, weak vector, string, substring or uniform vector
into an array of chars. If result array in arg 2 is NULL, malloc a
new one. If out of memory, return NULL. */
char *
gh_scm2chars (SCM obj, char *m)
{
long i, n;
long v;
SCM val;
if (SCM_IMP (obj))
scm_wrong_type_arg (0, 0, obj);
switch (SCM_TYP7 (obj))
{
case scm_tc7_vector:
case scm_tc7_wvect:
n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (SCM_I_INUMP (val))
{
v = SCM_I_INUM (val);
if (v < -128 || v > 255)
scm_out_of_range (0, obj);
}
else
scm_wrong_type_arg (0, 0, obj);
}
if (m == 0)
m = (char *) malloc (n * sizeof (char));
if (m == NULL)
return NULL;
for (i = 0; i < n; ++i)
m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i));
break;
case scm_tc7_smob:
if (scm_is_true (scm_s8vector_p (obj)))
{
scm_t_array_handle handle;
size_t len;
ssize_t inc;
const scm_t_int8 *elts;
elts = scm_s8vector_elements (obj, &handle, &len, &inc);
if (inc != 1)
scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
scm_list_1 (obj));
if (m == 0)
m = (char *) malloc (len);
if (m != NULL)
memcpy (m, elts, len);
scm_array_handle_release (&handle);
if (m == NULL)
return NULL;
break;
}
else
goto wrong_type;
case scm_tc7_string:
n = scm_i_string_length (obj);
if (m == 0)
m = (char *) malloc (n * sizeof (char));
if (m == NULL)
return NULL;
memcpy (m, scm_i_string_chars (obj), n * sizeof (char));
break;
default:
wrong_type:
scm_wrong_type_arg (0, 0, obj);
}
return m;
}
static void *
scm2whatever (SCM obj, void *m, size_t size)
{
scm_t_array_handle handle;
size_t len;
ssize_t inc;
const void *elts;
elts = scm_uniform_vector_elements (obj, &handle, &len, &inc);
if (inc != 1)
scm_misc_error (NULL, "only contiguous vectors can be converted: ~a",
scm_list_1 (obj));
if (m == 0)
m = malloc (len * sizeof (size));
if (m != NULL)
memcpy (m, elts, len * size);
scm_array_handle_release (&handle);
return m;
}
#define SCM2WHATEVER(obj,pred,utype,mtype) \
if (scm_is_true (pred (obj))) \
{ \
assert (sizeof (utype) == sizeof (mtype)); \
return (mtype *)scm2whatever (obj, m, sizeof (utype)); \
}
/* Convert a vector, weak vector or uniform vector into an array of
shorts. If result array in arg 2 is NULL, malloc a new one. If
out of memory, return NULL. */
short *
gh_scm2shorts (SCM obj, short *m)
{
long i, n;
long v;
SCM val;
if (SCM_IMP (obj))
scm_wrong_type_arg (0, 0, obj);
SCM2WHATEVER (obj, scm_s16vector_p, scm_t_int16, short)
switch (SCM_TYP7 (obj))
{
case scm_tc7_vector:
case scm_tc7_wvect:
n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (SCM_I_INUMP (val))
{
v = SCM_I_INUM (val);
if (v < -32768 || v > 65535)
scm_out_of_range (0, obj);
}
else
scm_wrong_type_arg (0, 0, obj);
}
if (m == 0)
m = (short *) malloc (n * sizeof (short));
if (m == NULL)
return NULL;
for (i = 0; i < n; ++i)
m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i));
break;
default:
scm_wrong_type_arg (0, 0, obj);
}
return m;
}
/* Convert a vector, weak vector or uniform vector into an array of
longs. If result array in arg 2 is NULL, malloc a new one. If out
of memory, return NULL. */
long *
gh_scm2longs (SCM obj, long *m)
{
long i, n;
SCM val;
if (SCM_IMP (obj))
scm_wrong_type_arg (0, 0, obj);
SCM2WHATEVER (obj, scm_s32vector_p, scm_t_int32, long)
switch (SCM_TYP7 (obj))
{
case scm_tc7_vector:
case scm_tc7_wvect:
n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (!SCM_I_INUMP (val) && !SCM_BIGP (val))
scm_wrong_type_arg (0, 0, obj);
}
if (m == 0)
m = (long *) malloc (n * sizeof (long));
if (m == NULL)
return NULL;
for (i = 0; i < n; ++i)
{
val = SCM_SIMPLE_VECTOR_REF (obj, i);
m[i] = SCM_I_INUMP (val)
? SCM_I_INUM (val)
: scm_to_long (val);
}
break;
default:
scm_wrong_type_arg (0, 0, obj);
}
return m;
}
/* Convert a vector, weak vector or uniform vector into an array of
floats. If result array in arg 2 is NULL, malloc a new one. If
out of memory, return NULL. */
float *
gh_scm2floats (SCM obj, float *m)
{
long i, n;
SCM val;
if (SCM_IMP (obj))
scm_wrong_type_arg (0, 0, obj);
/* XXX - f64vectors are rejected now.
*/
SCM2WHATEVER (obj, scm_f32vector_p, float, float)
switch (SCM_TYP7 (obj))
{
case scm_tc7_vector:
case scm_tc7_wvect:
n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (!SCM_I_INUMP (val)
&& !(SCM_BIGP (val) || SCM_REALP (val)))
scm_wrong_type_arg (0, 0, val);
}
if (m == 0)
m = (float *) malloc (n * sizeof (float));
if (m == NULL)
return NULL;
for (i = 0; i < n; ++i)
{
val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (SCM_I_INUMP (val))
m[i] = SCM_I_INUM (val);
else if (SCM_BIGP (val))
m[i] = scm_to_long (val);
else
m[i] = SCM_REAL_VALUE (val);
}
break;
default:
scm_wrong_type_arg (0, 0, obj);
}
return m;
}
/* Convert a vector, weak vector or uniform vector into an array of
doubles. If result array in arg 2 is NULL, malloc a new one. If
out of memory, return NULL. */
double *
gh_scm2doubles (SCM obj, double *m)
{
long i, n;
SCM val;
if (SCM_IMP (obj))
scm_wrong_type_arg (0, 0, obj);
/* XXX - f32vectors are rejected now.
*/
SCM2WHATEVER (obj, scm_f64vector_p, double, double)
switch (SCM_TYP7 (obj))
{
case scm_tc7_vector:
case scm_tc7_wvect:
n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (!SCM_I_INUMP (val)
&& !(SCM_BIGP (val) || SCM_REALP (val)))
scm_wrong_type_arg (0, 0, val);
}
if (m == 0)
m = (double *) malloc (n * sizeof (double));
if (m == NULL)
return NULL;
for (i = 0; i < n; ++i)
{
val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (SCM_I_INUMP (val))
m[i] = SCM_I_INUM (val);
else if (SCM_BIGP (val))
m[i] = scm_to_long (val);
else
m[i] = SCM_REAL_VALUE (val);
}
break;
default:
scm_wrong_type_arg (0, 0, obj);
}
return m;
}
/* string conversions between C and Scheme */
/* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a
new copy of its contents, followed by a null byte. If lenp is
non-null, set *lenp to the string's length.
This function uses malloc to obtain storage for the copy; the
caller is responsible for freeing it. If out of memory, NULL is
returned.
Note that Scheme strings may contain arbitrary data, including null
characters. This means that null termination is not a reliable way
to determine the length of the returned value. However, the
function always copies the complete contents of STR, and sets
*LEN_P to the true length of the string (when LEN_P is non-null). */
char *
gh_scm2newstr (SCM str, size_t *lenp)
{
char *ret_str;
/* We can't use scm_to_locale_stringn directly since it does not
guarantee null-termination when lenp is non-NULL.
*/
ret_str = scm_to_locale_string (str);
if (lenp)
*lenp = scm_i_string_length (str);
return ret_str;
}
/* Copy LEN characters at START from the Scheme string SRC to memory
at DST. START is an index into SRC; zero means the beginning of
the string. DST has already been allocated by the caller.
If START + LEN is off the end of SRC, silently truncate the source
region to fit the string. If truncation occurs, the corresponding
area of DST is left unchanged. */
void
gh_get_substr (SCM src, char *dst, long start, size_t len)
{
size_t src_len, effective_length;
SCM_ASSERT (scm_is_string (src), src, SCM_ARG3, "gh_get_substr");
src_len = scm_i_string_length (src);
effective_length = (len < src_len) ? len : src_len;
memcpy (dst + start, scm_i_string_chars (src), effective_length * sizeof (char));
/* FIXME: must signal an error if len > src_len */
scm_remember_upto_here_1 (src);
}
/* gh_scm2newsymbol() -- Given a Scheme symbol 'identifier, return a
pointer to a string with the symbol characters "identifier",
followed by a null byte. If lenp is non-null, set *lenp to the
string's length.
This function uses malloc to obtain storage for the copy; the
caller is responsible for freeing it. If out of memory, NULL is
returned.*/
char *
gh_symbol2newstr (SCM sym, size_t *lenp)
{
return gh_scm2newstr (scm_symbol_to_string (sym), lenp);
}
/* create a new vector of the given length, all initialized to the
given value */
SCM
gh_make_vector (SCM len, SCM fill)
{
return scm_make_vector (len, fill);
}
/* set the given element of the given vector to the given value */
SCM
gh_vector_set_x (SCM vec, SCM pos, SCM val)
{
return scm_vector_set_x (vec, pos, val);
}
/* retrieve the given element of the given vector */
SCM
gh_vector_ref (SCM vec, SCM pos)
{
return scm_vector_ref (vec, pos);
}
/* returns the length of the given vector */
unsigned long
gh_vector_length (SCM v)
{
return (unsigned long) scm_c_vector_length (v);
}
/* uniform vector support */
/* returns the length as a C unsigned long integer */
unsigned long
gh_uniform_vector_length (SCM v)
{
return (unsigned long) scm_c_uniform_vector_length (v);
}
/* gets the given element from a uniform vector; ilist is a list (or
possibly a single integer) of indices, and its length is the
dimension of the uniform vector */
SCM
gh_uniform_vector_ref (SCM v, SCM ilist)
{
return scm_uniform_vector_ref (v, ilist);
}
/* sets an individual element in a uniform vector */
/* SCM */
/* gh_list_to_uniform_array ( */
/* Data lookups between C and Scheme
Look up a symbol with a given name, and return the object to which
it is bound. gh_lookup examines the Guile top level, and
gh_module_lookup checks the module namespace specified by the
`vec' argument.
The return value is the Scheme object to which SNAME is bound, or
SCM_UNDEFINED if SNAME is not bound in the given context.
*/
SCM
gh_lookup (const char *sname)
{
return gh_module_lookup (scm_current_module (), sname);
}
SCM
gh_module_lookup (SCM module, const char *sname)
#define FUNC_NAME "gh_module_lookup"
{
SCM sym, var;
SCM_VALIDATE_MODULE (SCM_ARG1, module);
sym = scm_from_locale_symbol (sname);
var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
if (var != SCM_BOOL_F)
return SCM_VARIABLE_REF (var);
else
return SCM_UNDEFINED;
}
#undef FUNC_NAME
#endif /* SCM_ENABLE_DEPRECATED */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

109
libguile/gh_eval.c
View file

@ -1,109 +0,0 @@
/* Copyright (C) 1995,1996,1997,1998, 2000, 2001, 2006, 2008 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
/* routines to evaluate Scheme code */
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include "libguile/gh.h"
#if SCM_ENABLE_DEPRECATED
typedef SCM (*gh_eval_t) (void *data, SCM jmpbuf);
/* Evaluate the string; toss the value. */
SCM
gh_eval_str (const char *scheme_code)
{
return scm_c_eval_string (scheme_code);
}
/* evaluate the file by passing it to the lower level scm_primitive_load() */
SCM
gh_eval_file (const char *fname)
{
return scm_primitive_load (gh_str02scm (fname));
}
static SCM
eval_str_wrapper (void *data)
{
/* gh_eval_t real_eval_proc = (gh_eval_t) (* ((gh_eval_t *) data)); */
char *scheme_code = (char *) data;
return gh_eval_str (scheme_code);
}
SCM
gh_eval_str_with_catch (const char *scheme_code, scm_t_catch_handler handler)
{
/* FIXME: not there yet */
return gh_catch (SCM_BOOL_T, (scm_t_catch_body) eval_str_wrapper, (void *) scheme_code,
(scm_t_catch_handler) handler, (void *) scheme_code);
}
SCM
gh_eval_str_with_standard_handler (const char *scheme_code)
{
return gh_eval_str_with_catch (scheme_code, gh_standard_handler);
}
SCM
gh_eval_str_with_stack_saving_handler (const char *scheme_code)
{
return scm_internal_stack_catch (SCM_BOOL_T,
(scm_t_catch_body) eval_str_wrapper,
(void *) scheme_code,
(scm_t_catch_handler)
gh_standard_handler,
(void *) scheme_code);
}
static SCM
eval_file_wrapper (void *data)
{
/* gh_eval_t real_eval_proc = (gh_eval_t) (* ((gh_eval_t *) data)); */
char *scheme_code = (char *) data;
return gh_eval_file (scheme_code);
}
SCM
gh_eval_file_with_catch (const char *scheme_code, scm_t_catch_handler handler)
{
/* FIXME: not there yet */
return gh_catch (SCM_BOOL_T, (scm_t_catch_body) eval_file_wrapper,
(void *) scheme_code, (scm_t_catch_handler) handler,
(void *) scheme_code);
}
SCM
gh_eval_file_with_standard_handler (const char *scheme_code)
{
return gh_eval_file_with_catch (scheme_code, gh_standard_handler);
}
#endif /* SCM_ENABLE_DEPRECATED */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

157
libguile/gh_funcs.c
View file

@ -1,157 +0,0 @@
/* Copyright (C) 1995,1996,1997,1998, 2000, 2001, 2006, 2008 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
/* Defining Scheme functions implemented by C functions --- subrs. */
#include "libguile/gh.h"
#if SCM_ENABLE_DEPRECATED
/* allows you to define new scheme primitives written in C */
SCM
gh_new_procedure (const char *proc_name, SCM (*fn) (),
int n_required_args, int n_optional_args, int varp)
{
return scm_c_define_gsubr (proc_name, n_required_args, n_optional_args,
varp, fn);
}
SCM
gh_new_procedure0_0 (const char *proc_name, SCM (*fn) ())
{
return gh_new_procedure (proc_name, fn, 0, 0, 0);
}
SCM
gh_new_procedure0_1 (const char *proc_name, SCM (*fn) ())
{
return gh_new_procedure (proc_name, fn, 0, 1, 0);
}
SCM
gh_new_procedure0_2 (const char *proc_name, SCM (*fn) ())
{
return gh_new_procedure (proc_name, fn, 0, 2, 0);
}
SCM
gh_new_procedure1_0 (const char *proc_name, SCM (*fn) ())
{
return gh_new_procedure (proc_name, fn, 1, 0, 0);
}
SCM
gh_new_procedure1_1 (const char *proc_name, SCM (*fn) ())
{
return gh_new_procedure (proc_name, fn, 1, 1, 0);
}
SCM
gh_new_procedure1_2 (const char *proc_name, SCM (*fn) ())
{
return gh_new_procedure (proc_name, fn, 1, 2, 0);
}
SCM
gh_new_procedure2_0 (const char *proc_name, SCM (*fn) ())
{
return gh_new_procedure (proc_name, fn, 2, 0, 0);
}
SCM
gh_new_procedure2_1 (const char *proc_name, SCM (*fn) ())
{
return gh_new_procedure (proc_name, fn, 2, 1, 0);
}
SCM
gh_new_procedure2_2 (const char *proc_name, SCM (*fn) ())
{
return gh_new_procedure (proc_name, fn, 2, 2, 0);
}
SCM
gh_new_procedure3_0 (const char *proc_name, SCM (*fn) ())
{
return gh_new_procedure (proc_name, fn, 3, 0, 0);
}
SCM
gh_new_procedure4_0 (const char *proc_name, SCM (*fn) ())
{
return gh_new_procedure (proc_name, fn, 4, 0, 0);
}
SCM
gh_new_procedure5_0 (const char *proc_name, SCM (*fn) ())
{
return gh_new_procedure (proc_name, fn, 5, 0, 0);
}
/* some (possibly most) Scheme functions available from C */
SCM
gh_define (const char *name, SCM val)
{
scm_c_define (name, val);
return SCM_UNSPECIFIED;
}
/* Calling Scheme functions from C. */
SCM
gh_apply (SCM proc, SCM args)
{
return scm_apply (proc, args, SCM_EOL);
}
SCM
gh_call0 (SCM proc)
{
return scm_apply (proc, SCM_EOL, SCM_EOL);
}
SCM
gh_call1 (SCM proc, SCM arg)
{
return scm_apply (proc, arg, scm_listofnull);
}
SCM
gh_call2 (SCM proc, SCM arg1, SCM arg2)
{
return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
}
SCM
gh_call3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
{
return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
}
#endif /* SCM_ENABLE_DEPRECATED */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

94
libguile/gh_init.c
View file

@ -1,94 +0,0 @@
/* Copyright (C) 1995,1996,1997,2000,2001, 2006, 2008 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
/* Guile high level (gh_) interface, initialization-related stuff */
#include <stdio.h>
#include "libguile/gh.h"
#if SCM_ENABLE_DEPRECATED
typedef void (*main_prog_t) (int argc, char **argv);
typedef void (*repl_prog_t) (int argc, char **argv);
/* This function takes care of all real GH initialization. Since it's
called by scm_boot_guile, it can safely work with heap objects, or
call functions that do so. */
static void
gh_launch_pad (void *closure, int argc, char **argv)
{
main_prog_t c_main_prog = (main_prog_t) closure;
c_main_prog (argc, argv);
exit (0);
}
/* starts up the Scheme interpreter, and stays in it. c_main_prog()
is the address of the user's main program, since gh_enter() never
returns. */
void
gh_enter (int argc, char *argv[], main_prog_t c_main_prog)
{
scm_boot_guile (argc, argv, gh_launch_pad, (void *) c_main_prog);
/* never returns */
}
/* offer a REPL to the C programmer; for now I just invoke the ice-9
REPL that is written in Scheme */
void
gh_repl (int argc, char *argv[])
{
/* gh_eval_str ("(top-repl)"); */
scm_shell (argc, argv);
}
/* libguile programmers need exception handling mechanisms; here is
the recommended way of doing it with the gh_ interface */
/* gh_catch() -- set up an exception handler for a particular type of
error (or any thrown error if tag is SCM_BOOL_T); see
../libguile/throw.c for the comments explaining scm_internal_catch */
SCM
gh_catch (SCM tag, scm_t_catch_body body, void *body_data,
scm_t_catch_handler handler, void *handler_data)
{
return scm_internal_catch (tag, body, body_data, handler, handler_data);
}
SCM
gh_standard_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args SCM_UNUSED)
{
fprintf (stderr, "\nJust got an error; tag is\n ");
scm_display (tag, scm_current_output_port ());
scm_newline (scm_current_output_port ());
scm_newline (scm_current_output_port ());
return SCM_BOOL_F;
}
#endif /* SCM_ENABLE_DEPRECATED */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

50
libguile/gh_io.c
View file

@ -1,50 +0,0 @@
/* Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include "libguile/gh.h"
#if SCM_ENABLE_DEPRECATED
void
gh_display (SCM x)
{
scm_display (x, scm_current_output_port ());
}
void
gh_write (SCM x)
{
scm_write (x, scm_current_output_port ());
}
void
gh_newline ()
{
scm_newline (scm_current_output_port ());
}
#endif /* SCM_ENABLE_DEPRECATED */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

181
libguile/gh_list.c
View file

@ -1,181 +0,0 @@
/* Copyright (C) 1995,1996,1997, 2000, 2001, 2004, 2006, 2008 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
/* list manipulation */
#include "libguile/gh.h"
#if SCM_ENABLE_DEPRECATED
/* returns the length of a list */
unsigned long
gh_length (SCM l)
{
return gh_scm2ulong (scm_length (l));
}
/* list operations */
/* gh_list(SCM elt, ...) is implemented as a macro in gh.h. */
/* gh_append() takes a args, which is a list of lists, and appends
them all together into a single list, which is returned. This is
equivalent to the Scheme procedure (append list1 list2 ...) */
SCM
gh_append (SCM args)
{
return scm_append (args);
}
SCM
gh_append2 (SCM l1, SCM l2)
{
return scm_append (scm_list_2 (l1, l2));
}
SCM
gh_append3(SCM l1, SCM l2, SCM l3)
{
return scm_append (scm_list_3 (l1, l2, l3));
}
SCM
gh_append4 (SCM l1, SCM l2, SCM l3, SCM l4)
{
return scm_append (scm_list_4 (l1, l2, l3, l4));
}
/* gh_reverse() is defined as a macro in gh.h */
/* gh_list_tail() is defined as a macro in gh.h */
/* gh_list_ref() is defined as a macro in gh.h */
/* gh_memq() is defined as a macro in gh.h */
/* gh_memv() is defined as a macro in gh.h */
/* gh_member() is defined as a macro in gh.h */
/* gh_assq() is defined as a macro in gh.h */
/* gh_assv() is defined as a macro in gh.h */
/* gh_assoc() is defined as a macro in gh.h */
/* analogous to the Scheme cons operator */
SCM
gh_cons (SCM x, SCM y)
{
return scm_cons (x, y);
}
/* analogous to the Scheme car operator */
SCM
gh_car (SCM x)
{
return scm_car (x);
}
/* analogous to the Scheme cdr operator */
SCM
gh_cdr (SCM x)
{
return scm_cdr (x);
}
/* now for the multiple car/cdr utility procedures */
SCM
gh_caar (SCM x)
{
return scm_caar (x);
}
SCM
gh_cadr (SCM x)
{
return scm_cadr (x);
}
SCM
gh_cdar (SCM x)
{
return scm_cdar (x);
}
SCM
gh_cddr (SCM x)
{
return scm_cddr (x);
}
SCM
gh_caaar (SCM x)
{
return scm_caaar (x);
}
SCM
gh_caadr (SCM x)
{
return scm_caadr (x);
}
SCM
gh_cadar (SCM x)
{
return scm_cadar (x);
}
SCM
gh_caddr (SCM x)
{
return scm_caddr (x);
}
SCM
gh_cdaar (SCM x)
{
return scm_cdaar (x);
}
SCM
gh_cdadr (SCM x)
{
return scm_cdadr (x);
}
SCM
gh_cddar (SCM x)
{
return scm_cddar (x);
}
SCM
gh_cdddr (SCM x)
{
return scm_cdddr (x);
}
/* equivalent to (set-car! pair value) */
SCM
gh_set_car_x(SCM pair, SCM value)
{
return scm_set_car_x(pair, value);
}
/* equivalent to (set-cdr! pair value) */
SCM
gh_set_cdr_x(SCM pair, SCM value)
{
return scm_set_cdr_x(pair, value);
}
#endif /* SCM_ENABLE_DEPRECATED */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

124
libguile/gh_predicates.c
View file

@ -1,124 +0,0 @@
/* Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
/* type predicates and equality predicates */
#include "libguile/gh.h"
#if SCM_ENABLE_DEPRECATED
/* type predicates: tell you if an SCM object has a given type */
int
gh_boolean_p (SCM val)
{
return (scm_is_true (scm_boolean_p (val)));
}
int
gh_symbol_p (SCM val)
{
return (scm_is_true (scm_symbol_p (val)));
}
int
gh_char_p (SCM val)
{
return (scm_is_true (scm_char_p (val)));
}
int
gh_vector_p (SCM val)
{
return (scm_is_true (scm_vector_p (val)));
}
int
gh_pair_p (SCM val)
{
return (scm_is_true (scm_pair_p (val)));
}
int
gh_number_p (SCM val)
{
return (scm_is_true (scm_number_p (val)));
}
int
gh_string_p (SCM val)
{
return (scm_is_true (scm_string_p (val)));
}
int
gh_procedure_p (SCM val)
{
return (scm_is_true (scm_procedure_p (val)));
}
int
gh_list_p (SCM val)
{
return (scm_is_true (scm_list_p (val)));
}
int
gh_inexact_p (SCM val)
{
return (scm_is_true (scm_inexact_p (val)));
}
int
gh_exact_p (SCM val)
{
return (scm_is_true (scm_exact_p (val)));
}
/* the three types of equality */
int
gh_eq_p (SCM x, SCM y)
{
return (scm_is_true (scm_eq_p (x, y)));
}
int
gh_eqv_p (SCM x, SCM y)
{
return (scm_is_true (scm_eqv_p (x, y)));
}
int
gh_equal_p (SCM x, SCM y)
{
return (scm_is_true (scm_equal_p (x, y)));
}
/* equivalent to (string=? ...), but returns 0 or 1 rather than Scheme
booleans */
int
gh_string_equal_p(SCM s1, SCM s2)
{
return (scm_is_true (scm_string_equal_p(s1, s2)));
}
/* equivalent to (null? ...), but returns 0 or 1 rather than Scheme
booleans */
int
gh_null_p(SCM l)
{
return (scm_is_true(scm_null_p(l)));
}
#endif /* SCM_ENABLE_DEPRECATED */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

2
libguile/read.c
View file

@ -484,7 +484,7 @@ scm_read_string (int chr, SCM port)
else else
str = (str == SCM_BOOL_F) ? scm_nullstr : str; str = (str == SCM_BOOL_F) ? scm_nullstr : str;
return scm_i_make_read_only_string (str); return str;
} }
#undef FUNC_NAME #undef FUNC_NAME

11
libguile/script.c
View file

@ -26,12 +26,15 @@
#include <ctype.h> #include <ctype.h>
#include "libguile/_scm.h" #include "libguile/_scm.h"
#include "libguile/gh.h" #include "libguile/eval.h"
#include "libguile/feature.h"
#include "libguile/load.h" #include "libguile/load.h"
#include "libguile/version.h" #include "libguile/read.h"
#include "libguile/validate.h"
#include "libguile/script.h" #include "libguile/script.h"
#include "libguile/strings.h"
#include "libguile/strports.h"
#include "libguile/validate.h"
#include "libguile/version.h"
#ifdef HAVE_STRING_H #ifdef HAVE_STRING_H
#include <string.h> #include <string.h>

37
libguile/strings.c
View file

@ -204,12 +204,6 @@ get_str_buf_start (SCM *str, SCM *buf, size_t *start)
*buf = STRING_STRINGBUF (*str); *buf = STRING_STRINGBUF (*str);
} }
SCM
scm_i_make_read_only_string (SCM str)
{
return scm_i_substring_read_only (str, 0, STRING_LENGTH (str));
}
SCM SCM
scm_i_substring (SCM str, size_t start, size_t end) scm_i_substring (SCM str, size_t start, size_t end)
{ {
@ -227,28 +221,15 @@ scm_i_substring (SCM str, size_t start, size_t end)
SCM SCM
scm_i_substring_read_only (SCM str, size_t start, size_t end) scm_i_substring_read_only (SCM str, size_t start, size_t end)
{ {
SCM result; SCM buf;
size_t str_start;
if (SCM_UNLIKELY (STRING_LENGTH (str) == 0)) get_str_buf_start (&str, &buf, &str_start);
/* We want the empty string to be `eq?' with the read-only empty scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
string. */ SET_STRINGBUF_SHARED (buf);
result = str; scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
else return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf),
{ (scm_t_bits)str_start + start,
SCM buf; (scm_t_bits) end - start);
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);
result = scm_double_cell (RO_STRING_TAG, SCM_UNPACK (buf),
(scm_t_bits) str_start + start,
(scm_t_bits) end - start);
}
return result;
} }
SCM SCM

1
libguile/strings.h
View file

@ -143,7 +143,6 @@ SCM_INTERNAL void scm_i_get_substring_spec (size_t len,
SCM start, size_t *cstart, SCM start, size_t *cstart,
SCM end, size_t *cend); SCM end, size_t *cend);
SCM_INTERNAL SCM scm_i_take_stringbufn (char *str, size_t len); SCM_INTERNAL SCM scm_i_take_stringbufn (char *str, size_t len);
SCM_INTERNAL SCM scm_i_make_read_only_string (SCM str);
/* deprecated stuff */ /* deprecated stuff */

7
test-suite/standalone/Makefile.am
View file

@ -72,13 +72,6 @@ test_round_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-round check_PROGRAMS += test-round
TESTS += test-round TESTS += test-round
# test-gh
test_gh_SOURCES = test-gh.c
test_gh_CFLAGS = ${test_cflags}
test_gh_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-gh
TESTS += test-gh
# test-asmobs # test-asmobs
noinst_LTLIBRARIES += libtest-asmobs.la noinst_LTLIBRARIES += libtest-asmobs.la
libtest_asmobs_la_SOURCES = test-asmobs-lib.c test-asmobs-lib.x libtest_asmobs_la_SOURCES = test-asmobs-lib.c test-asmobs-lib.x

95
test-suite/standalone/test-gh.c
View file

@ -1,95 +0,0 @@
/* Copyright (C) 1999,2000,2001,2003, 2006, 2008 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
/* some bits originally by Jim Blandy <jimb@red-bean.com> */
#ifndef HAVE_CONFIG_H
# include <config.h>
#endif
#include <libguile.h>
#include <libguile/gh.h>
#include <assert.h>
#include <string.h>
#if SCM_ENABLE_DEPRECATED
static int
string_equal (SCM str, char *lit)
{
int len = strlen (lit);
int result;
result = ((scm_c_string_length (str) == len)
&& (!memcmp (scm_i_string_chars (str), lit, len)));
scm_remember_upto_here_1 (str);
return result;
}
static void
test_gh_set_substr ()
{
SCM string;
string = gh_str02scm ("Free, darnit!");
assert (gh_string_p (string));
gh_set_substr ("dammit", string, 6, 6);
assert (string_equal (string, "Free, dammit!"));
/* Make sure that we can use the string itself as a source.
I guess this behavior isn't really visible, since the GH API
doesn't provide any direct access to the string contents. But I
think it should, eventually. You can't write efficient string
code if you have to copy the string just to look at it. */
/* Copy a substring to an overlapping region to its right. */
gh_set_substr (scm_i_string_chars (string), string, 4, 6);
assert (string_equal (string, "FreeFree, it!"));
string = gh_str02scm ("Free, darnit!");
assert (gh_string_p (string));
/* Copy a substring to an overlapping region to its left. */
gh_set_substr (scm_i_string_chars (string) + 6, string, 2, 6);
assert (string_equal (string, "Frdarnitrnit!"));
}
static void
tests (void *data, int argc, char **argv)
{
test_gh_set_substr ();
}
int
main (int argc, char *argv[])
{
scm_boot_guile (argc, argv, tests, NULL);
return 0;
}
#else
int
main (int argc, char *argv[])
{
return 0;
}
#endif /* !SCM_ENABLE_DEPRECATED */

9
test-suite/tests/reader.test
View file

@ -88,7 +88,14 @@
(pass-if "CR recognized as a token delimiter" (pass-if "CR recognized as a token delimiter"
;; In 1.8.3, character 0x0d was not recognized as a delimiter. ;; In 1.8.3, character 0x0d was not recognized as a delimiter.
(equal? (read-string "one\x0dtwo") 'one))) (equal? (read-string "one\x0dtwo") 'one))
(pass-if "returned strings are mutable"
;; Per R5RS Section 3.4, "Storage Model", `read' is supposed to return
;; mutable objects.
(let ((str (with-input-from-string "\"hello, world\"" read)))
(string-set! str 0 #\H)
(string=? str "Hello, world"))))
(pass-if-exception "radix passed to number->string can't be zero" (pass-if-exception "radix passed to number->string can't be zero"

31
test-suite/tests/regexp.test
View file

@ -1,7 +1,7 @@
;;;; regexp.test --- test Guile's regular expression functions -*- scheme -*- ;;;; regexp.test --- test Guile's regular expression functions -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
;;;; ;;;;
;;;; Copyright (C) 1999, 2004, 2006, 2007 Free Software Foundation, Inc. ;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -18,9 +18,11 @@
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA ;;;; Boston, MA 02110-1301 USA
(use-modules (test-suite lib) (define-module (test-suite test-regexp)
(ice-9 regex)) #:use-module (test-suite lib)
#:use-module (ice-9 regex))
;;; Run a regexp-substitute or regexp-substitute/global test, once ;;; Run a regexp-substitute or regexp-substitute/global test, once
;;; providing a real port and once providing #f, requesting direct ;;; providing a real port and once providing #f, requesting direct
;;; string output. ;;; string output.
@ -102,6 +104,29 @@
(let ((re (make-regexp "ab+"))) (let ((re (make-regexp "ab+")))
(regexp-exec re "aaaabbbb" 0 'bogus-flags-arg)))) (regexp-exec re "aaaabbbb" 0 'bogus-flags-arg))))
;;;
;;; fold-matches
;;;
(with-test-prefix "fold-matches"
(pass-if "without flags"
(equal? '("hello")
(fold-matches "^[a-z]+$" "hello" '()
(lambda (match result)
(cons (match:substring match)
result)))))
(pass-if "with flags"
;; Prior to 1.8.6, passing an additional flag would not work.
(null?
(fold-matches "^[a-z]+$" "hello" '()
(lambda (match result)
(cons (match:substring match)
result))
(logior regexp/notbol regexp/noteol)))))
;;; ;;;
;;; regexp-quote ;;; regexp-quote
;;; ;;;

8
test-suite/tests/strings.test
View file

@ -1,7 +1,7 @@
;;;; strings.test --- test suite for Guile's string functions -*- scheme -*- ;;;; strings.test --- test suite for Guile's string functions -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- August 1999 ;;;; Jim Blandy <jimb@red-bean.com> --- August 1999
;;;; ;;;;
;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. ;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -168,11 +168,7 @@
(pass-if-exception "read-only string" (pass-if-exception "read-only string"
exception:read-only-string exception:read-only-string
(string-set! (substring/read-only "abc" 0) 1 #\space)) (string-set! (substring/read-only "abc" 0) 1 #\space)))
(pass-if-exception "literal string"
exception:read-only-string
(string-set! "an immutable string" 0 #\a)))
(with-test-prefix "string-split" (with-test-prefix "string-split"