code:
Some of the thread support code (threads.c, coop.c, etc.) used to live
in a separate directory called threads.  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.

Mon Feb 24 21:48:12 1997  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>

	* configure.in: Added AM_MAINTAINER_MODE

Fri Feb 21 23:52:16 1997  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>

	* Makefile.am (modincludedir, modinclude_HEADERS): Added until
	libthreads is integrated into libguile, otherwise people who try
	to use Guile from an independent application will have trouble
	finding libguile/../threads/threads.h.

Sat Jan 11 18:35:39 1997  Marius Vollmer  <mvo@zagadka.ping.de>

	* Makefile.am (noinst_HEADERS): Added coop-defs.h so that it gets
 	distributed.

Tue Jan  7 14:05:35 1997  Mikael Djurfeldt  <mdj@kenneth>

	* coop-defs.h: Added includes which define `time_t'.

Sun Jan  5 15:07:07 1997  Jim Blandy  <jimb@floss.cyclic.com>

	* Makefile.am (EXTRA_DIST): Add .cvsignore.

	* Makefile.am (libthreads_a_SOURCES): Add threads.h.  I think this
	is right...
	(noinst_HEADERS): Remove it from here.
	* Makefile.in: Rebuilt.

Thu Jan  2 15:15:16 1997  Mikael Djurfeldt  <mdj@kenneth>

	These changes separates threads declarations which everybody wants
 	to see (coop-defs.h) from declarations internal to the threads
 	module (coop-threads.h), thereby solving the "-I ../qt" problem.
	(This is not the final solution.  All files in the threads
 	directory should be moved into libguile since 1. it is too tightly
 	interconnected with libguile internals to be a separate module and
 	2. it is actually quite small.  When doing this, things can be
 	organized in a more natural way.)

	* coop-defs.h: New file.

	* coop-threads.c: Added #include "coop-threads.h"

	* coop-threads.h: Moved coop_t struct and threads macros to
	coop-defs.h.  Added #include "coop-defs.h".

	* threads.h: Changed #include "coop-threads.h" --> #include
	"coop-defs.h".

Mon Dec  9 17:20:39 1996  Tom Tromey  <tromey@cygnus.com>

	* Makefile.am (.c.x): Use guile-snarf.
	(INCLUDES): Search for headers in libguile source and build
	directories.

Mon Dec  2 20:37:07 1996  Tom Tromey  <tromey@cygnus.com>

	* PLUGIN/greet: Removed.
	* Makefile.am, aclocal.m4: New files.
	* configure.in: Updated for Automake.

Sun Nov 10 18:21:00 1996  Jim Blandy  <jimb@totoro.cyclic.com>

	* Makefile.in (uninstall_threads): rmdir -f isn't portable;
	use rm -rf instead.

Sun Nov 10 17:41:21 1996  Jim Blandy  <jimb@floss.cyclic.com>

	* Makefile.in, configure.in: When threads are disabled,
 	short-circuit the `install' and `uninstall' Makefile targets too.

Sat Nov  2 21:29:33 1996  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>

	* threads.c: Added #include "dynwind.h".
	Added scheme level procedure `single-active-thread?'.

	* mit-pthreads.c, mit-pthreads.h: Port completed but untested.

	* coop-threads.h: Increased SCM_THREAD_SWITCH_COUNT from 10 to 50
	to decrease overhead at the cost of granularity.

	* coop.c, coop-threads.h: Made coop_global_runq and
	coop_global_sleepq visible globally.

	* coop-threads.c (scm_single_thread_p): New function.

Thu Oct 24 22:37:03 1996  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>

	* threads.c: #include "dynwind.h"

	* coop-threads.c (scm_threads_mark_stacks): Removed unused
 	variable.

	* coop.c (coop_qput, coop_all_qput, coop_all_qremove): Removed
 	unused variable.

Wed Oct  9 19:46:00 1996  Jim Blandy  <jimb@floss.cyclic.com>

	* Makefile.in: Doc fixes.

	* Makefile.in (ancillary): Corrected spelling from `ancillery'.

	* Makefile.in (source, h_files, ancillary): Updated to describe
	the actual contents of the tree.
	(PLUGIN_distfiles): New variable.
	(dist-dir): New target, to create a sub-tree of a distribution.

	* Makefile.in (all): Depend on @target_all@ instead of
 	libthreads.a, so the configure script can make this makefile do
 	nothing when threads aren't in use.
	* configure.in: If we using cooperative threads, then let
	@target_all@ expand to libthreads.a; otherwise, let it expand to
	the empty string.

Sat Oct  5 18:40:09 1996  Mikael Djurfeldt  <mdj@kenneth>

	* threads.c, threads.h (scm_init_threads, scm_threads_init): Added
	stack base pointer argument so that main thread can be initialized
	properly.

	* configure.in: Added lines to set default -g flag in CFLAGS and
	LDFLAGS.

	* coop-threads.c: Added argument checking to scheme level
	procedures.  Change the way threads are launched.

	* threads.h: Added #include "procs.h"
	Added macros SCM_THREADP, SCM_MUTEXP and SCM_CONDVARP.

Wed Oct  2 14:36:44 1996  Mikael Djurfeldt  <mdj@woody.nada.kth.se>

	* coop-threads.c (scm_threads_free_thread, scm_threads_free_mutex,
 	scm_threads_free_condvar):  free --> scm_must_free

	* coop-threads.h: Added macros SCM_THREAD_LOCAL_DATA and
	SCM_SET_THREAD_LOCAL_DATA.

Tue Oct  1 00:05:54 1996  Mikael Djurfeldt  <mdj@woody.nada.kth.se>

	* coop-threads.c (scm_threads_mark_stacks): scm_save_regs_gc_mark
	is already in root state (should it really?).  Don't allocate it
	locally; Remove extra argument to scm_mark_locations.

	* coop-threads.h: Changed #include <qt.h> --> #include "../qt/qt.h"
	(SCM_THREAD_INITIALIZE_STORAGE, SCM_DEFER_INTS, SCM_ALLOW_INTS,
 	SCM_REDEFER_INTS, SCM_REALLOW_INTS, scm_coop_create_info_type):
 	Removed; Declaration of scm_coop_create_info removed.  Added
 	definition of SCM_THREADS_SWITCHING_CODE.

	* coop-threads.c: Removed gscm_type objects.  Renamed all
 	  gscm_threads_<type>_die --> scm_threads_free_<type> and let them
 	  return freed size as smob freeing code normally does.  Removed
 	  thread creation mutex and thread creation info structure.
	(gscm_threads_thread_equal, gscm_pthread_delete_info,
 	 scm_threads_init): Removed.
	(scm_threads_init_coop_threads): Removed allocation of thread
 	  local data.  Removed initialization of thread creation mutex.
  	  Renamed scm_threads_init_coop_threads --> scm_threads_init.
	(scm_threads_mark_stacks): Mark root object instead of local
 	  protects.
	(launch_thread): thunk and handler is passed as a scheme list.
  	  Call scm_with_new_root instead of scm_with_dynamic_root.  Let
 	  scm_with_new_root care about thread local variables.  Removed
 	  unlocking of creation mutex.
	(scm_call_with_new_thread): Remove initialization of create info
 	  structure and locking of creation mutex.  Do smob allocation.
	(scm_join_thread): Extract thread data in a new way.
	(scm_make_mutex): Do smob allocation.
	(scm_lock_mutex, scm_unlock_mutex): Extract thread data in a new
 	way.
	(scm_make_condition_variable): Do smob allocation.
	(scm_wait_condition_variable, scm_signal_condition_variable):
 	Extract thread data in a new way.

	* threads.c: Don't use files "no-threads.[hc]".  Removed old code
 	for creation of thread, mutex and condition-variable objects.
  	Added smobs instead.  Use scm_threads_free_<type> for freeing.
	(scm_init_threads): Moved scm_add_feature ("threads") to
 	feature.c.

	* threads.h: Added declaration of scm_init_threads.  Added macro
 	selectors SCM_THREAD_DATA, SCM_MUTEX_DATA and SCM_CONDVAR_DATA.

	* coop-threads.c, coop-threads.h, coop.c, fsu-pthreads.h,
	mit-pthreads.c, mit-pthreads.h, threads.c, threads.h: Replaced
	"gscm" --> "scm" everywhere.  Lots of name changes to concord with
	new Guile.

Thu Apr  4 10:19:56 1996  Tom Tromey  <tromey@creche.cygnus.com>

	Fixed CFLAGS usage:
	* Makefile.in (XCFLAGS): New macro.
	(.c.x): Use it.
	(.c.o): Ditto.
	* configure.in: Use DEFS, not X_CFLAGS.

Fri Mar 29 17:08:14 1996  Anthony Green  <green@snuffle.cygnus.com>

	* no-threads.c (gscm_threads_init_all): This function is now
	found in libguile.

Fri Mar 29 16:52:27 1996  Tom Tromey  <tromey@creche.cygnus.com>

	* configure.in (CFLAGS): Use "test !=", not "! test".

Fri Mar 29 11:51:18 1996  Anthony Green  <green@snuffle.cygnus.com>

	* Makefile.in (install): make install now works properly.

Thu Mar 28 07:52:11 1996  Anthony Green  <green@csk3.cygnus.com>

	* mit-pthreads.c: dynwinds set to BOOL_T for new threads.
	Added dummy yield function.

Tue Mar 26 15:17:42 1996  Anthony Green  (green@gerbil.cygnus.com)

	* coop.c: Added new sleep() function. Behaves properly
	among multiple cooperative threads. Replaces system call.

Mon Mar 25 11:05:41 1996  Anthony Green  (green@gerbil.cygnus.com)

	* coop.c (COOP_STKSIZE): Boosted default stack size.

	* coop-threads.c: Moved declaration of scm_coop_create_info
	to avoid multiple definitions at link time.

Sun Mar 24 23:04:29 1996  Anthony Green  (green@gerbil.cygnus.com)

        * configure: Rebuilt
	* configure.in: Upgraded thread library/include support.

Tue Mar 19 12:44:26 1996  Anthony Green  (green@gerbil.cygnus.com)

	* coop.c, coop-threads.h coop-threads.c: Major cleanup of
        cooperative threading code.

Tue Feb 13 15:45:39 1996  Anthony Green  <green@hoser.cygnus.com>

	* mit-pthreads.h: Defined pthread aware SCM_DEFER_INTS and friends.

Mon Feb 12 19:59:55 1996  Anthony Green  <green@hoser.cygnus.com>

	* threads.c, no-threads.c, mit-pthreads.c, threads.scm: Creation.

path: libguile/ChangeLog-threads


code:
## Process this file with Automake to create Makefile.in
##
##  	Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
##
##   This file is part of GUILE.
##
##   GUILE is free software; you can redistribute it and/or modify
##   it under the terms of the GNU General Public License as
##   published by the Free Software Foundation; either version 2, or
##   (at your option) any later version.
##
##   GUILE 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 General Public License for more details.
##
##   You should have received a copy of the GNU General Public
##   License along with GUILE; see the file COPYING.  If not, write
##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
##   Floor, Boston, MA 02110-1301 USA

AUTOMAKE_OPTIONS = gnu

## Prevent automake from adding extra -I options
DEFS = @DEFS@

# Override Automake's `DEFAULT_INCLUDES'.  By default, it contains
# "-I$(srcdir)", which causes problems on Tru64 where our "random.h"
# is picked up by <stdlib.h> instead of the libc's <random.h>.
DEFAULT_INCLUDES =

## Check for headers in $(srcdir)/.., so that #include
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
## building.
AM_CPPFLAGS = -I.. -I$(top_srcdir) -I$(top_builddir)

ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_LONG\).*\"\([^\"]\)*\"/\3/' \
   --regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/'

lib_LTLIBRARIES = libguile.la
bin_PROGRAMS = guile

noinst_PROGRAMS = guile_filter_doc_snarfage gen-scmconfig

gen_scmconfig_SOURCES = gen-scmconfig.c

## Override default rule; this should be compiled for BUILD host.
## For some reason, OBJEXT does not include the dot
gen-scmconfig.$(OBJEXT): gen-scmconfig.c
	if [ "$(cross_compiling)" = "yes" ]; then \
		$(CC_FOR_BUILD) $(DEFS) $(DEFAULT_INCLUDES) $(AM_CPPFLAGS) -c -o $@ $<; \
	else \
		$(COMPILE) -c -o $@ $<; \
	fi

## Override default rule; this should run on BUILD host.
gen-scmconfig$(EXEEXT): $(gen_scmconfig_OBJECTS) $(gen_scmconfig_DEPENDENCIES)
	@rm -f gen-scmconfig$(EXEEXT)
	if [ "$(cross_compiling)" = "yes" ]; then \
		$(CCLD_FOR_BUILD) -o $@ $(gen_scmconfig_OBJECTS); \
	else \
		$(LINK) $(gen_scmconfig_OBJECTS) $(LDADD) $(LIBS); \
	fi

scmconfig.h: ${top_builddir}/config.h gen-scmconfig$(EXEEXT)
	rm -f scmconfig.h.tmp
	cat $(srcdir)/scmconfig.h.top > scmconfig.h.tmp
	./gen-scmconfig$(EXEEXT) >> scmconfig.h.tmp
	chmod 444 scmconfig.h.tmp
	rm -f scmconfig.h
	mv scmconfig.h.tmp scmconfig.h

guile_filter_doc_snarfage_SOURCES = c-tokenize.c

## Override default rule; this should be compiled for BUILD host.
## For some reason, OBJEXT does not include the dot
c-tokenize.$(OBJEXT): c-tokenize.c
	if [ "$(cross_compiling)" = "yes" ]; then \
		$(CC_FOR_BUILD) $(DEFS) $(AM_CPPFLAGS) -c -o $@ $<; \
	else \
		$(COMPILE) -c -o $@ $<; \
	fi

## Override default rule; this should run on BUILD host.
guile_filter_doc_snarfage$(EXEEXT): $(guile_filter_doc_snarfage_OBJECTS) $(guile_filter_doc_snarfage_DEPENDENCIES)
	@rm -f guile_filter_doc_snarfage$(EXEEXT)
	if [ "$(cross_compiling)" = "yes" ]; then \
		$(CCLD_FOR_BUILD) -o $@ $(guile_filter_doc_snarfage_OBJECTS); \
	else \
		$(LINK) $(guile_filter_doc_snarfage_OBJECTS) $(LDADD) $(LIBS); \
	fi

guile_SOURCES = guile.c
guile_CFLAGS = $(GUILE_CFLAGS)
guile_LDADD = libguile.la
guile_LDFLAGS = $(GUILE_CFLAGS)

libguile_la_CFLAGS = $(GUILE_CFLAGS)

libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c	\
    chars.c continuations.c convert.c debug.c deprecation.c		\
    deprecated.c discouraged.c dynwind.c environments.c eq.c error.c	\
    eval.c evalext.c extensions.c feature.c fluids.c fports.c		\
    futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c		\
    gc-freelist.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.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 i18n.c init.c inline.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	\
    print.c procprop.c procs.c properties.c random.c rdelim.c read.c	\
    root.c rw.c scmsigs.c script.c simpos.c smob.c sort.c srcprop.c	\
    stackchk.c stacks.c stime.c strings.c srfi-4.c srfi-13.c srfi-14.c	\
    strorder.c strports.c struct.c symbols.c threads.c null-threads.c	\
    throw.c values.c variable.c vectors.c version.c vports.c weaks.c	\
    ramap.c unif.c

DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x	\
    continuations.x debug.x deprecation.x deprecated.x discouraged.x	\
    dynl.x dynwind.x environments.x eq.x error.x eval.x evalext.x	\
    extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x	\
    gc-segment.x gc-malloc.x gc-card.x goops.x gsubr.x guardians.x	\
    hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x	\
    list.x load.x macros.x mallocs.x modules.x numbers.x objects.x	\
    objprop.x options.x pairs.x ports.x print.x procprop.x procs.x	\
    properties.x random.x rdelim.x read.x root.x rw.x scmsigs.x		\
    script.x simpos.x smob.x sort.x srcprop.x stackchk.x stacks.x	\
    stime.x strings.x srfi-4.x srfi-13.x srfi-14.x strorder.x		\
    strports.x struct.x symbols.x threads.x throw.x values.x		\
    variable.x vectors.x version.x vports.x weaks.x ramap.x unif.x

EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@

DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc		\
    boolean.doc chars.doc continuations.doc debug.doc deprecation.doc	\
    deprecated.doc discouraged.doc dynl.doc dynwind.doc			\
    environments.doc eq.doc error.doc eval.doc evalext.doc		\
    extensions.doc feature.doc fluids.doc fports.doc futures.doc	\
    gc.doc goops.doc gsubr.doc gc-mark.doc gc-segment.doc		\
    gc-malloc.doc gc-card.doc guardians.doc hash.doc hashtab.doc	\
    hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc		\
    list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc	\
    objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc	\
    procprop.doc procs.doc properties.doc random.doc rdelim.doc		\
    read.doc root.doc rw.doc scmsigs.doc script.doc simpos.doc		\
    smob.doc sort.doc srcprop.doc stackchk.doc stacks.doc stime.doc	\
    strings.doc srfi-4.doc srfi-13.doc srfi-14.doc strorder.doc		\
    strports.doc struct.doc symbols.doc threads.doc throw.doc		\
    values.doc variable.doc vectors.doc version.doc vports.doc		\
    weaks.doc ramap.doc unif.doc

EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@

BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h \
    version.h scmconfig.h \
    $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)

EXTRA_libguile_la_SOURCES = _scm.h		\
    inet_aton.c memmove.c putenv.c strerror.c	\
    dynl.c regex-posix.c			\
    filesys.c posix.c net_db.c socket.c		\
    debug-malloc.c mkstemp.c	\
    win32-uname.c win32-dirent.c win32-socket.c

## delete guile-snarf.awk from the installation bindir, in case it's
## lingering there due to an earlier guile version not having been
## wiped out.
install-exec-hook:
	rm -f $(DESTDIR)$(bindir)/guile-snarf.awk

## This is kind of nasty... there are ".c" files that we don't want to
## compile, since they are #included.  So instead we list them here.
## Perhaps we can deal with them normally once the merge seems to be
## working.
noinst_HEADERS = convert.i.c					\
                 conv-integer.i.c conv-uinteger.i.c		\
                 srfi-4.i.c					\
                 quicksort.i.c                                  \
                 win32-uname.h win32-dirent.h win32-socket.h	\
	         private-gc.h

libguile_la_DEPENDENCIES = @LIBLOBJS@
libguile_la_LIBADD = @LIBLOBJS@
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>
pkginclude_HEADERS = gh.h

# These are headers visible as <libguile/mumble.h>.
modincludedir = $(includedir)/libguile
modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h	\
    boolean.h chars.h continuations.h convert.h debug.h debug-malloc.h	\
    deprecation.h deprecated.h discouraged.h dynl.h dynwind.h		\
    environments.h eq.h error.h eval.h evalext.h extensions.h		\
    feature.h filesys.h fluids.h fports.h futures.h gc.h		\
    gdb_interface.h gdbint.h goops.h gsubr.h guardians.h hash.h		\
    hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h		\
    keywords.h lang.h list.h load.h macros.h mallocs.h modules.h	\
    net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h	\
    posix.h regex-posix.h print.h procprop.h procs.h properties.h	\
    random.h ramap.h rdelim.h read.h root.h rw.h scmsigs.h validate.h	\
    script.h simpos.h smob.h snarf.h socket.h sort.h srcprop.h		\
    stackchk.h stacks.h stime.h strings.h srfi-4.h srfi-13.h srfi-14.h	\
    strorder.h strports.h struct.h symbols.h tags.h threads.h		\
    pthread-threads.h null-threads.h throw.h unif.h values.h		\
    variable.h vectors.h vports.h weaks.h

nodist_modinclude_HEADERS = version.h scmconfig.h

bin_SCRIPTS = guile-snarf

# We can re-enable install for some of these if/when they are documented
# 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

EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads		\
    ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 cpp_signal.c	\
    cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c			\
    cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk			\
    c-tokenize.lex version.h.in						\
    scmconfig.h.top gettext.h measure-hwm.scm
#    $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \
#    guile-procedures.txt guile.texi

## We use @-...-@ as the substitution brackets here, instead of the
## usual @...@, so autoconf doesn't go and substitute the values
## directly into the left-hand sides of the sed substitutions.  *sigh*
version.h: version.h.in
	sed < $(srcdir)/version.h.in > $@.tmp \
	  -e s:@-GUILE_MAJOR_VERSION-@:${GUILE_MAJOR_VERSION}: \
	  -e s:@-GUILE_MINOR_VERSION-@:${GUILE_MINOR_VERSION}: \
	  -e s:@-GUILE_MICRO_VERSION-@:${GUILE_MICRO_VERSION}:
	mv $@.tmp $@

## FIXME: Consider using timestamp file, to avoid unnecessary rebuilds.
libpath.h: $(srcdir)/Makefile.in  $(top_builddir)/config.status
	@echo "Generating libpath.h..."
	@rm -f libpath.tmp
	@echo '/* generated by Makefile */' > libpath.tmp
	@echo '#define SCM_PKGDATA_DIR "$(pkgdatadir)"' >> libpath.tmp
	@echo '#define SCM_LIBRARY_DIR "$(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)"'>>libpath.tmp
	@echo '#define SCM_SITE_DIR "$(pkgdatadir)/site"' >> libpath.tmp
	@echo '#define SCM_BUILD_INFO { \' >> libpath.tmp
	@echo '	{ "srcdir", "'"`cd @srcdir@; pwd`"'" }, \' >> libpath.tmp
	@echo ' { "top_srcdir",    "@top_srcdir_absolute@" }, \' >> libpath.tmp
	@echo '	{ "prefix",	   "@prefix@" }, \' >> libpath.tmp
	@echo '	{ "exec_prefix",   "@exec_prefix@" }, \' >> libpath.tmp
	@echo '	{ "bindir",	   "@bindir@" }, \' >> libpath.tmp
	@echo '	{ "sbindir",	   "@sbindir@" }, \' >> libpath.tmp
	@echo '	{ "libexecdir",	   "@libexecdir@" }, \' >> libpath.tmp
	@echo '	{ "datadir",	   "@datadir@" }, \' >> libpath.tmp
	@echo '	{ "sysconfdir",	   "@sysconfdir@" }, \' >> libpath.tmp
	@echo '	{ "sharedstatedir", "@sharedstatedir@" }, \' >> libpath.tmp
	@echo '	{ "localstatedir", "@localstatedir@" }, \' >> libpath.tmp
	@echo '	{ "libdir",	   "@libdir@" }, \' >> libpath.tmp
	@echo '	{ "infodir",	   "@infodir@" }, \' >> libpath.tmp
	@echo '	{ "mandir",	   "@mandir@" }, \' >> libpath.tmp
	@echo '	{ "includedir",	   "@includedir@" }, \' >> libpath.tmp
	@echo '	{ "pkgdatadir",	   "$(datadir)/@PACKAGE@" }, \' >> libpath.tmp
	@echo '	{ "pkglibdir",	   "$(libdir)/@PACKAGE@" }, \' >> libpath.tmp
	@echo '	{ "pkgincludedir", "$(includedir)/@PACKAGE@" }, \' \
		>> libpath.tmp
	@echo '	{ "guileversion", "@GUILE_VERSION@" }, \' >> libpath.tmp
	@echo '	{ "libguileinterface", "@LIBGUILE_INTERFACE@" }, \' \
		>> libpath.tmp
	@echo '	{ "LIBS",	   "@GUILE_LIBS@" }, \' >> libpath.tmp
	@echo '	{ "CFLAGS",	   "@GUILE_CFLAGS@" }, \' >> libpath.tmp
	@echo '	{ "buildstamp",    "'"`date`"'" }, \' >> libpath.tmp
	@echo '}' >> libpath.tmp
	@mv libpath.tmp libpath.h

snarfcppopts = $(DEFS) $(AM_CPPFLAGS) $(CPPFLAGS) $(CFLAGS)

SUFFIXES = .x .doc
.c.x:
	./guile-snarf -o $@ $< $(snarfcppopts)
.c.doc:
	-$(AWK) -f ./guile-func-name-check $<
	(./guile-snarf-docs $(snarfcppopts) $< | \
	./guile_filter_doc_snarfage$(EXEEXT) --filter-snarfage) > $@ || { rm $@; false; }

$(DOT_X_FILES) $(EXTRA_DOT_X_FILES): scmconfig.h snarf.h guile-snarf.in

$(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES): scmconfig.h snarf.h guile-snarf-docs.in guile_filter_doc_snarfage$(EXEEXT)

error.x: cpp_err_symbols.c
posix.x: cpp_sig_symbols.c
load.x: libpath.h

include $(top_srcdir)/am/pre-inst-guile

alldotdocfiles    = $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES)
snarf2checkedtexi = GUILE="$(GUILE_FOR_BUILD)" $(top_srcdir)/scripts/snarf-check-and-output-texi
dotdoc2texi       = cat $(alldotdocfiles) | $(snarf2checkedtexi)

guile.texi: $(alldotdocfiles) guile$(EXEEXT)
	$(dotdoc2texi) --manual > $@ || { rm $@; false; }

guile-procedures.texi: $(alldotdocfiles) guile$(EXEEXT)
	$(dotdoc2texi)          > $@ || { rm $@; false; }

if HAVE_MAKEINFO

guile-procedures.txt: guile-procedures.texi
	rm -f $@
	makeinfo --force -o $@ guile-procedures.texi || test -f $@

else

guile-procedures.txt: guile-procedures.texi
	cp guile-procedures.texi $@

endif

# Stack limit calibration for `make check'.  (For why we do this, see
# the comments in measure-hwm.scm.)  We're relying here on a couple of
# bits of Automake magic.
#
# 1. The fact that "libguile" comes before "test-suite" in SUBDIRS in
# our toplevel Makefile.am.  This ensures that the
# stack-limit-calibration.scm "test" will be run before any of the
# tests under test-suite.
#
# 2. The fact that each test is invoked as $TESTS_ENVIRONMENT $test.
# This allows us to ensure that the test will be considered to have
# passed, by using `true' as TESTS_ENVIRONMENT.
#
# Why don't we care about the test "actually passing"?  Because the
# important thing about stack-limit-calibration.scm is just that it is
# generated in the first place, so that other tests under test-suite
# can use it.
TESTS = stack-limit-calibration.scm
TESTS_ENVIRONMENT = true

stack-limit-calibration.scm: measure-hwm.scm guile$(EXEEXT)
	$(preinstguile) -s $(srcdir)/measure-hwm.scm > $@

c-tokenize.c: c-tokenize.lex
	flex -t $(srcdir)/c-tokenize.lex > $@ || { rm $@; false; }

schemelibdir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)

## Add -MG to make the .x magic work with auto-dep code.
MKDEP = gcc -M -MG $(DEFS) $(AM_CPPFLAGS) $(CPPFLAGS) $(CFLAGS)

cpp_err_symbols.c: cpp_err_symbols.in cpp_cnvt.awk
	$(AWK) -f $(srcdir)/cpp_cnvt.awk < $(srcdir)/cpp_err_symbols.in > \
		cpp_err_symbols.tmp
	mv cpp_err_symbols.tmp cpp_err_symbols.c

cpp_sig_symbols.c: cpp_sig_symbols.in cpp_cnvt.awk
	$(AWK) -f $(srcdir)/cpp_cnvt.awk < $(srcdir)/cpp_sig_symbols.in > \
		cpp_sig_symbols.tmp
	mv cpp_sig_symbols.tmp cpp_sig_symbols.c

## Create a new version of the cpp_sig_symbols.in file, including all SIGXXX
## macros defined on this platform.
check_signals:
	gcc -undef -dM -E $(srcdir)/cpp_signal.c | egrep ' SIG[A-Z]+' \
	  | cut -f2 -d' ' | sort > cpp_sig_symbols_here
	diff -u $(srcdir)/cpp_sig_symbols.in cpp_sig_symbols_here \
          | egrep '^\+S' \
	  | cut -c2- > cpp_sig_symbols_diff
	if test -s cpp_sig_symbols_diff ; then \
	  cat $(srcdir)/cpp_sig_symbols.in cpp_sig_symbols_diff \
	    | sort > cpp_sig_symbols_new ;\
	  echo "cpp_sig_symbols_new has the following additions:" ;\
	  cat cpp_sig_symbols_diff ;\
	else echo "No new symbols found."; \
	fi

## Likewise for cpp_err_symbols.in.
check_errnos:
	gcc -undef -dM -E $(srcdir)/cpp_errno.c | egrep ' E.+' \
	  | cut -f2 -d' ' | sort > cpp_err_symbols_here
	diff -u $(srcdir)/cpp_err_symbols.in cpp_err_symbols_here \
          | egrep '^\+E' \
	  | cut -c2- > cpp_err_symbols_diff
	if test -s cpp_err_symbols_diff ; then \
	  cat $(srcdir)/cpp_err_symbols.in cpp_err_symbols_diff \
	    | sort > cpp_err_symbols_new ;\
	  echo "cpp_err_symbols_new has the following additions:" ;\
	  cat cpp_err_symbols_diff ;\
	else echo "No new symbols found."; \
	fi

MOSTLYCLEANFILES = \
	cpp_err_symbols_here cpp_err_symbols_diff cpp_err_symbols_new \
	cpp_sig_symbols_here cpp_sig_symbols_diff cpp_sig_symbols_new \
	version.h version.h.tmp \
	scmconfig.h scmconfig.h.tmp stack-limit-calibration.scm

CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi

MAINTAINERCLEANFILES = c-tokenize.c

license: unknown


code:
/* classes: h_files */

#ifndef SCM___SCM_H
#define SCM___SCM_H

/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003, 2006, 2007, 2008, 2010 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
 */

/**********************************************************************
 This file is Guile's central public header.

 When included by other files, this file should preceed any include
 other than __scm.h.

 Under *NO* circumstances should new items be added to the global
 namespace (via adding #define, typedef, or similar to this file) with
 generic names.  This usually means that any new names should be
 prefixed by either SCM_ or GUILE_.  i.e. do *not* #define HAVE_FOO or
 SIZEOF_BAR.  See configure.in, gen-scmconfig.h.in, and
 gen-scmconfig.c for examples of how to properly handle this issue.
 The main documentation is in gen-scmconfig.c.

 "What's the difference between _scm.h and __scm.h?"

   _scm.h is not installed; it's only visible to the libguile sources
   themselves, and it includes config.h, the private config header.

   __scm.h is installed, and is #included by <libguile.h>.  If both
   the client and libguile need some piece of information, and it
   doesn't fit well into the header file for any particular module, it
   should go in __scm.h.  __scm.h includes scmconfig.h, the public
   config header.
 **********************************************************************/

/* What did the configure script discover about the outside world?  */
#include "libguile/scmconfig.h"

/* {Compiler hints}
 *
 * The following macros are used to provide additional information for the
 * compiler, which may help to do better error checking and code
 * optimization.  A second benefit of these macros is, that they also provide
 * additional information to the developers.
 */

/* The macro SCM_NORETURN indicates that a function will never return.
 * Examples:
 *   1) int foo (char arg) SCM_NORETURN;
 */
#ifdef __GNUC__
#define SCM_NORETURN __attribute__ ((noreturn))
#else
#define SCM_NORETURN
#endif

/* The macro SCM_UNUSED indicates that a function, function argument or
 * variable may potentially be unused.
 * Examples:
 *   1) static int unused_function (char arg) SCM_UNUSED;
 *   2) int foo (char unused_argument SCM_UNUSED);
 *   3) int unused_variable SCM_UNUSED;
 */
#ifdef __GNUC__
#define SCM_UNUSED __attribute__ ((unused))
#else
#define SCM_UNUSED
#endif

/* The SCM_EXPECT macros provide branch prediction hints to the compiler.  To
 * use only in places where the result of the expression under "normal"
 * circumstances is known.  */
#if defined(__GNUC__) && (__GNUC__ >= 3)
# define SCM_EXPECT    __builtin_expect
#else
# define SCM_EXPECT(_expr, _value) (_expr)
#endif

#define SCM_LIKELY(_expr)    SCM_EXPECT ((_expr), 1)
#define SCM_UNLIKELY(_expr)  SCM_EXPECT ((_expr), 0)

/* {Supported Options}
 *
 * These may be defined or undefined.
 */

/* #define GUILE_DEBUG_FREELIST */

/* All the number support there is.
 */
#define BIGNUMS

/* GC should relinquish empty cons-pair arenas. */
/* cmm:FIXME look at this after done mangling the GC */
/* #define GC_FREE_SEGMENTS */

/* Provide a scheme-accessible count-down timer that
 * generates a pseudo-interrupt.
 */
#define TICKS

/* Use engineering notation when converting numbers strings?
 */
#undef ENGNOT

/* {Unsupported Options}
 *
 * These must be defined as given here.
 */

#define CCLO

/* Guile Scheme supports the #f/() distinction; Guile Lisp won't.  We
   have horrible plans for their unification.  */
#undef SICP

/* Random options (not yet supported or in final form). */

#define STACK_CHECKING
#undef NO_CEVAL_STACK_CHECKING

/* SCM_API is a macro prepended to all function and data definitions
   which should be exported or imported in the resulting dynamic link
   library (DLL) in the Win32 port. */

#if defined (SCM_IMPORT)
# define SCM_API __declspec (dllimport) extern
#elif defined (SCM_EXPORT) || defined (DLL_EXPORT)
# define SCM_API __declspec (dllexport) extern
#else
# define SCM_API extern
#endif

/* {Debugging Options}
 *
 * These compile time options determine whether to include code that is only
 * useful for debugging guile itself or C level extensions to guile.  The
 * common prefix for all option macros of this kind is "SCM_DEBUG_".  It is
 * guaranteed that a macro named SCM_DEBUG_XXX is always defined (typically to
 * either 0 or 1), i. e. there is no need to test for the undefined case.
 * This allows to use these definitions comfortably within code, as in the
 * following example:
 *   #define FOO do { if (SCM_DEBUG_XXX) bar(); else baz(); } while (0)
 * Any sane compiler will remove the unused branch without any performance
 * penalty for the resulting code.
 *
 * Note:  Some SCM_DEBUG_XXX options are not settable at configure time.
 * To change the value of such options you will have to edit this header
 * file or give suitable options to make, like:
 *   make all CFLAGS="-DSCM_DEBUG_XXX=1 ..."
 */

/* The value of SCM_DEBUG determines the default for most of the not yet
 * defined debugging options.  This allows, for example, to enable most of the
 * debugging options by simply defining SCM_DEBUG as 1.
 */
#ifndef SCM_DEBUG
#define SCM_DEBUG 0
#endif

/* If SCM_DEBUG_CELL_ACCESSES is set to 1, cell accesses will perform
 * exhaustive parameter checking:  It will be verified that cell parameters
 * actually point to a valid heap cell.  Note:  If this option is enabled,
 * guile will run about ten times slower than normally.
 */
#ifndef SCM_DEBUG_CELL_ACCESSES
#define SCM_DEBUG_CELL_ACCESSES SCM_DEBUG
#endif

/* If SCM_DEBUG_INTERRUPTS is set to 1, with every deferring and allowing of
 * interrupts a consistency check will be performed.
 */
#ifndef SCM_DEBUG_INTERRUPTS
#define SCM_DEBUG_INTERRUPTS SCM_DEBUG
#endif

/* If SCM_DEBUG_PAIR_ACCESSES is set to 1, accesses to cons cells will be
 * exhaustively checked.  Note:  If this option is enabled, guile will run
 * slower than normally.
 */
#ifndef SCM_DEBUG_PAIR_ACCESSES
#define SCM_DEBUG_PAIR_ACCESSES SCM_DEBUG
#endif

/* If SCM_DEBUG_REST_ARGUMENT is set to 1, functions that take rest arguments
 * will check whether the rest arguments are actually passed as a proper list.
 * Otherwise, if SCM_DEBUG_REST_ARGUMENT is 0, functions that take rest
 * arguments will take it for granted that these are passed as a proper list.
 */
#ifndef SCM_DEBUG_REST_ARGUMENT
#define SCM_DEBUG_REST_ARGUMENT SCM_DEBUG
#endif

/* The macro SCM_DEBUG_TYPING_STRICTNESS indicates what level of type checking
 * shall be performed with respect to the use of the SCM datatype.  The macro
 * may be defined to one of the values 0, 1 and 2.
 *
 * A value of 0 means that there will be no compile time type checking, since
 * the SCM datatype will be declared as an integral type.  This setting should
 * only be used on systems, where casting from integral types to pointers may
 * lead to loss of bit information.
 *
 * A value of 1 means that there will an intermediate level of compile time
 * type checking, since the SCM datatype will be declared as a pointer to an
 * undefined struct.  This setting is the default, since it does not cost
 * anything in terms of performance or code size.
 *
 * A value of 2 provides a maximum level of compile time type checking since
 * the SCM datatype will be declared as a struct.  This setting should be used
 * for _compile time_ type checking only, since the compiled result is likely
 * to be quite inefficient.  The right way to make use of this option is to do
 * a 'make clean; make CFLAGS=-DSCM_DEBUG_TYPING_STRICTNESS=2', fix your
 * errors, and then do 'make clean; make'.
 */
#ifndef SCM_DEBUG_TYPING_STRICTNESS
#define SCM_DEBUG_TYPING_STRICTNESS 1
#endif

/* If SCM_DEBUG_DEBUGGING_SUPPORT is set to 1, guile will provide a set of
 * special functions that support debugging with a debugger like gdb or
 * debugging of guile internals on the scheme level.  The behaviour of guile
 * is not changed by this macro, only the set of functions that are available
 * will differ.  All functions that are introduced this way have the prefix
 * 'scm_dbg_' on the C level and the prefix 'dbg-' on the scheme level.  This
 * allows to easily determine the set of support functions, given that your
 * debugger or repl provide automatic name completion.  Note that these
 * functions are intended to be used during interactive debugging sessions
 * only.  They are not considered part of guile's official API.  They may
 * change or disappear without notice or deprecation phase.
 */
#ifndef SCM_DEBUG_DEBUGGING_SUPPORT
#define SCM_DEBUG_DEBUGGING_SUPPORT SCM_DEBUG
#endif

/* {Feature Options}
 *
 * These compile time options determine whether code for certain features
 * should be compiled into guile.  The common prefix for all option macros
 * of this kind is "SCM_ENABLE_".  It is guaranteed that a macro named
 * SCM_ENABLE_XXX is defined to be either 0 or 1, i. e. there is no need to
 * test for the undefined case.  This allows to use these definitions
 * comfortably within code, as in the following example:
 *   #define FOO do { if (SCM_ENABLE_XXX) bar(); else baz(); } while (0)
 * Any sane compiler will remove the unused branch without any performance
 * penalty for the resulting code.
 *
 * Note:  Some SCM_ENABLE_XXX options are not settable at configure time.
 * To change the value of such options you will have to edit this header
 * file or give suitable options to make, like:
 *   make all CFLAGS="-DSCM_ENABLE_XXX=1 ..."
 */

/* If SCM_ENABLE_DEPRECATED is set to 1, deprecated code will be included in
 * guile, as well as some functions to issue run-time warnings about uses of
 * deprecated functions.
 */
#ifndef SCM_ENABLE_DEPRECATED
#define SCM_ENABLE_DEPRECATED 0
#endif

/* {Architecture and compiler properties}
 *
 * Guile as of today can only work on systems which fulfill at least the
 * following requirements:
 *
 * - scm_t_bits and SCM variables have at least 32 bits.
 *   Guile's type system is based on this assumption.
 *
 * - sizeof (scm_t_bits) >= sizeof (void*) and sizeof (SCM) >= sizeof (void*)
 *   Guile's type system is based on this assumption, since it must be
 *   possible to store pointers to cells on the heap in scm_t_bits and SCM
 *   variables.
 *
 * - sizeof (scm_t_bits) >= 4 and sizeof (scm_t_bits) is a power of 2.
 *   Guile's type system is based on this assumption.  In particular, it is
 *   assumed that cells, i. e. pairs of scm_t_bits variables, are eight
 *   character aligned.  This is because three bits of a scm_t_bits variable
 *   that is holding a pointer to a cell on the heap must be available for
 *   storing type data.
 *
 * - sizeof (scm_t_bits) <= sizeof (void*) and sizeof (SCM) <= sizeof (void*)
 *   In some parts of guile, scm_t_bits and SCM variables are passed to
 *   functions as void* arguments.  Together with the requirement above, this
 *   requires a one-to-one correspondence between the size of a void* and the
 *   sizes of scm_t_bits and SCM variables.
 *
 * - numbers are encoded using two's complement.
 *   The implementation of the bitwise scheme level operations is based on
 *   this assumption.
 *
 * - ... add more
 */

#ifdef CHAR_BIT
# define SCM_CHAR_BIT CHAR_BIT
#else
# define SCM_CHAR_BIT 8
#endif

#ifdef LONG_BIT
# define SCM_LONG_BIT LONG_BIT
#else
# define SCM_LONG_BIT (SCM_CHAR_BIT * sizeof (long) / sizeof (char))
#endif

#ifdef UCHAR_MAX
# define SCM_CHAR_CODE_LIMIT (UCHAR_MAX + 1L)
#else
# define SCM_CHAR_CODE_LIMIT 256L
#endif

#define SCM_I_UTYPE_MAX(type)      ((type)-1)
#define SCM_I_TYPE_MAX(type,umax)  ((type)((umax)/2))
#define SCM_I_TYPE_MIN(type,umax)  (-((type)((umax)/2))-1)

#define SCM_T_UINT8_MAX   SCM_I_UTYPE_MAX(scm_t_uint8)
#define SCM_T_INT8_MIN    SCM_I_TYPE_MIN(scm_t_int8,SCM_T_UINT8_MAX)
#define SCM_T_INT8_MAX    SCM_I_TYPE_MAX(scm_t_int8,SCM_T_UINT8_MAX)

#define SCM_T_UINT16_MAX  SCM_I_UTYPE_MAX(scm_t_uint16)
#define SCM_T_INT16_MIN   SCM_I_TYPE_MIN(scm_t_int16,SCM_T_UINT16_MAX)
#define SCM_T_INT16_MAX   SCM_I_TYPE_MAX(scm_t_int16,SCM_T_UINT16_MAX)

#define SCM_T_UINT32_MAX  SCM_I_UTYPE_MAX(scm_t_uint32)
#define SCM_T_INT32_MIN   SCM_I_TYPE_MIN(scm_t_int32,SCM_T_UINT32_MAX)
#define SCM_T_INT32_MAX   SCM_I_TYPE_MAX(scm_t_int32,SCM_T_UINT32_MAX)

#define SCM_T_UINT64_MAX  SCM_I_UTYPE_MAX(scm_t_uint64)
#define SCM_T_INT64_MIN   SCM_I_TYPE_MIN(scm_t_int64,SCM_T_UINT64_MAX)
#define SCM_T_INT64_MAX   SCM_I_TYPE_MAX(scm_t_int64,SCM_T_UINT64_MAX)

#if SCM_SIZEOF_LONG_LONG
#define SCM_I_ULLONG_MAX  SCM_I_UTYPE_MAX(unsigned long long)
#define SCM_I_LLONG_MIN   SCM_I_TYPE_MIN(long long,SCM_I_ULLONG_MAX)
#define SCM_I_LLONG_MAX   SCM_I_TYPE_MAX(long long,SCM_I_ULLONG_MAX)
#endif

#define SCM_T_UINTMAX_MAX SCM_I_UTYPE_MAX(scm_t_uintmax)
#define SCM_T_INTMAX_MIN  SCM_I_TYPE_MIN(scm_t_intmax,SCM_T_UINTMAX_MAX)
#define SCM_T_INTMAX_MAX  SCM_I_TYPE_MAX(scm_t_intmax,SCM_T_UINTMAX_MAX)

#define SCM_I_SIZE_MAX    SCM_I_UTYPE_MAX(size_t)
#define SCM_I_SSIZE_MIN   SCM_I_TYPE_MIN(ssize_t,SCM_I_SIZE_MAX)
#define SCM_I_SSIZE_MAX   SCM_I_TYPE_MAX(ssize_t,SCM_I_SIZE_MAX)

#include "libguile/tags.h"

#ifdef vms
# ifndef CHEAP_CONTINUATIONS
   typedef int jmp_buf[17];
   extern int setjump(jmp_buf env);
   extern int longjump(jmp_buf env, int ret);
#  define setjmp setjump
#  define longjmp longjump
# else
#  include <setjmp.h>
# endif
#else				/* ndef vms */
# ifdef _CRAY1
    typedef int jmp_buf[112];
    extern int setjump(jmp_buf env);
    extern int longjump(jmp_buf env, int ret);
#  define setjmp setjump
#  define longjmp longjump
# else				/* ndef _CRAY1 */
#  if defined (__ia64__)
/* For IA64, emulate the setjmp API using getcontext. */
#   include <signal.h>
#   include <ucontext.h>
    typedef struct {
      ucontext_t ctx;
      int fresh;
    } scm_i_jmp_buf;
#   define SCM_I_SETJMP(JB)			        \
      ( (JB).fresh = 1,				        \
        getcontext (&((JB).ctx)),			\
        ((JB).fresh ? ((JB).fresh = 0, 0) : 1) )
#   define SCM_I_LONGJMP(JB,VAL) scm_ia64_longjmp (&(JB), VAL)
    void scm_ia64_longjmp (scm_i_jmp_buf *, int);
#  else                 	/* ndef __ia64__ */
#   include <setjmp.h>
#  endif			/* ndef __ia64__ */
# endif				/* ndef _CRAY1 */
#endif				/* ndef vms */

/* For any platform where SCM_I_SETJMP hasn't been defined in some
   special way above, map SCM_I_SETJMP, SCM_I_LONGJMP and
   scm_i_jmp_buf to setjmp, longjmp and jmp_buf. */
#ifndef SCM_I_SETJMP
#define scm_i_jmp_buf jmp_buf
#define SCM_I_SETJMP setjmp
#define SCM_I_LONGJMP longjmp
#endif

/* James Clark came up with this neat one instruction fix for
 * continuations on the SPARC.  It flushes the register windows so
 * that all the state of the process is contained in the stack.
 */

#if defined (sparc) || defined (__sparc__) || defined (__sparc)
# define SCM_FLUSH_REGISTER_WINDOWS asm("ta 3")
#else
# define SCM_FLUSH_REGISTER_WINDOWS /* empty */
#endif

/* If stack is not longword aligned then
 */

/* #define SHORT_ALIGN */
#ifdef THINK_C
# define SHORT_ALIGN
#endif
#ifdef MSDOS
# define SHORT_ALIGN
#endif
#ifdef atarist
# define SHORT_ALIGN
#endif

#ifdef SHORT_ALIGN
typedef short SCM_STACKITEM;
#else
typedef long SCM_STACKITEM;
#endif

/* Cast pointer through (void *) in order to avoid compiler warnings
   when strict aliasing is enabled */
#define SCM_STACK_PTR(ptr) ((SCM_STACKITEM *) (void *) (ptr))

#define SCM_ASYNC_TICK /*fixme* should change names */ \
do { \
  if (SCM_I_CURRENT_THREAD->pending_asyncs) \
    scm_async_click (); \
} while (0)

/* Anthony Green writes:
   When the compiler sees...
	   DEFER_INTS;
	   [critical code here]
	   ALLOW_INTS;
   ...it doesn't actually promise to keep the critical code within the
   boundries of the DEFER/ALLOW_INTS instructions. It may very well
   schedule it outside of the magic defined in those macros.

   However, GCC's volatile asm feature forms a barrier over which code is
   never moved. So if you add...
	   asm ("");
   ...to each of the DEFER_INTS and ALLOW_INTS macros, the critical
   code will always remain in place.  asm's without inputs or outputs
   are implicitly volatile. */
#ifdef __GNUC__
#define SCM_FENCE asm /* volatile */ ("")
#elif defined (__INTEL_COMPILER) && defined (__ia64)
#define SCM_FENCE __memory_barrier()
#else
#define SCM_FENCE
#endif

#define SCM_TICK \
do { \
  SCM_ASYNC_TICK; \
  SCM_THREAD_SWITCHING_CODE; \
} while (0)

/** SCM_ASSERT
 **
 **/

#ifdef SCM_RECKLESS
#define SCM_ASSERT(_cond, _arg, _pos, _subr)
#define SCM_ASSERT_TYPE(_cond, _arg, _pos, _subr, _msg)
#define SCM_ASRTGO(_cond, _label)
#else
#define SCM_ASSERT(_cond, _arg, _pos, _subr)			\
        do { if (SCM_UNLIKELY (!(_cond)))			\
          scm_wrong_type_arg (_subr, _pos, _arg); } while (0)
#define SCM_ASSERT_TYPE(_cond, _arg, _pos, _subr, _msg)			\
        do { if (SCM_UNLIKELY (!(_cond)))				\
          scm_wrong_type_arg_msg(_subr, _pos, _arg, _msg);  } while (0)
#define SCM_ASRTGO(_cond, _label)		\
        do {  if (SCM_UNLIKELY (!(_cond)))	\
          goto _label; } while (0)
#endif

/*
 * SCM_WTA_DISPATCH
 */

/* Dirk:FIXME:: In all of the SCM_WTA_DISPATCH_* macros it is assumed that
 * 'gf' is zero if uninitialized.  It would be cleaner if some valid SCM value
 * like SCM_BOOL_F or SCM_UNDEFINED was chosen.
 */

SCM_API SCM scm_call_generic_0 (SCM gf);

#define SCM_WTA_DISPATCH_0(gf, subr)			        \
  return (SCM_UNPACK (gf)					\
	  ? scm_call_generic_0 ((gf))				\
	  : (scm_error_num_args_subr ((subr)), SCM_UNSPECIFIED))
#define SCM_GASSERT0(cond, gf, subr)		\
  if (SCM_UNLIKELY(!(cond)))		\
    SCM_WTA_DISPATCH_0((gf), (subr))

SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);

#define SCM_WTA_DISPATCH_1(gf, a1, pos, subr)			\
  return (SCM_UNPACK (gf)					\
	  ? scm_call_generic_1 ((gf), (a1))			\
	  : (scm_wrong_type_arg ((subr), (pos), (a1)), SCM_UNSPECIFIED))
#define SCM_GASSERT1(cond, gf, a1, pos, subr)		\
  if (SCM_UNLIKELY (!(cond)))			\
    SCM_WTA_DISPATCH_1((gf), (a1), (pos), (subr))

SCM_API SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2);

#define SCM_WTA_DISPATCH_2(gf, a1, a2, pos, subr)			\
  return (SCM_UNPACK (gf)						\
	  ? scm_call_generic_2 ((gf), (a1), (a2))			\
	  : (scm_wrong_type_arg ((subr), (pos),				\
				 (pos) == SCM_ARG1 ? (a1) : (a2)),	\
	     SCM_UNSPECIFIED))
#define SCM_GASSERT2(cond, gf, a1, a2, pos, subr)	\
  if (SCM_UNLIKELY (!(cond)))			\
    SCM_WTA_DISPATCH_2((gf), (a1), (a2), (pos), (subr))

SCM_API SCM scm_apply_generic (SCM gf, SCM args);

#define SCM_WTA_DISPATCH_n(gf, args, pos, subr)				  \
  return (SCM_UNPACK (gf)						  \
	  ? scm_apply_generic ((gf), (args))				  \
	  : (scm_wrong_type_arg ((subr), (pos),				  \
				 scm_list_ref ((args),			  \
					       scm_from_int ((pos) - 1))), \
	     SCM_UNSPECIFIED))
#define SCM_GASSERTn(cond, gf, args, pos, subr)		\
  if (SCM_UNLIKELY (!(cond)))			\
    SCM_WTA_DISPATCH_n((gf), (args), (pos), (subr))

#ifndef SCM_MAGIC_SNARFER
/* Let these macros pass through if
   we are snarfing;  thus we can tell the
   difference between the use of an actual
   number vs. the use of one of these macros --
   actual numbers in SCM_VALIDATE_* and SCM_ASSERT
   constructs must match the formal argument name,
   but using SCM_ARG* avoids the test */

#define SCM_ARGn 		0
#define SCM_ARG1 		1
#define SCM_ARG2 		2
#define SCM_ARG3 		3
#define SCM_ARG4 		4
#define SCM_ARG5 		5
#define SCM_ARG6 		6
#define SCM_ARG7 		7

#endif /* SCM_MAGIC_SNARFER */

/* SCM_EXIT_SUCCESS is the default code to return from SCM if no errors
 * were encountered.  SCM_EXIT_FAILURE is the default code to return from
 * SCM if errors were encountered.  The return code can be explicitly
 * specified in a SCM program with (scm_quit <n>).
 */

#ifndef SCM_EXIT_SUCCESS
#ifdef vms
#define SCM_EXIT_SUCCESS 1
#else
#define SCM_EXIT_SUCCESS 0
#endif /* def vms */
#endif /* ndef SCM_EXIT_SUCCESS */
#ifndef SCM_EXIT_FAILURE
#ifdef vms
#define SCM_EXIT_FAILURE 2
#else
#define SCM_EXIT_FAILURE 1
#endif /* def vms */
#endif /* ndef SCM_EXIT_FAILURE */

/* Define SCM_C_INLINE_KEYWORD so that it can be used as a replacement
   for the "inline" keyword, expanding to nothing when "inline" is not
   available.
*/

#ifdef SCM_C_INLINE
#define SCM_C_INLINE_KEYWORD SCM_C_INLINE
#else
#define SCM_C_INLINE_KEYWORD
#endif

#endif  /* SCM___SCM_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM__SCM_H
#define SCM__SCM_H

/* Copyright (C) 1995,1996,2000,2001, 2002, 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
 */

/**********************************************************************
 This file is Guile's central private header.

 When included by other files, this file should preceed any include
 other than __scm.h.  See __scm.h for details regarding the purpose of
 and differences between _scm.h and __scm.h.
 **********************************************************************/

#if defined(__ia64) && !defined(__ia64__)
# define __ia64__
#endif

#if HAVE_CONFIG_H
#  include <config.h>
#endif

/* Undefine HAVE_STRUCT_TIMESPEC, because the libguile C code doesn't
   need it anymore, and because on MinGW:

   - the definition of struct timespec is provided (if at all) by
     pthread.h

   - pthread.h will _not_ define struct timespec if
     HAVE_STRUCT_TIMESPEC is 1, because then it thinks that it doesn't
     need to.

   The libguile C code doesn't need HAVE_STRUCT_TIMESPEC anymore,
   because the value of HAVE_STRUCT_TIMESPEC has already been
   incorporated in how scm_t_timespec is defined (in scmconfig.h), and
   the rest of the libguile C code now just uses scm_t_timespec.
 */
#ifdef HAVE_STRUCT_TIMESPEC
#undef HAVE_STRUCT_TIMESPEC
#endif

#include <errno.h>
#include "libguile/__scm.h"

/* Include headers for those files central to the implementation.  The
   rest should be explicitly #included in the C files themselves.  */
#include "libguile/error.h"	/* Everyone signals errors.  */
#include "libguile/print.h"	/* Everyone needs to print.  */
#include "libguile/pairs.h"	/* Everyone conses.  */
#include "libguile/list.h"	/* Everyone makes lists.  */
#include "libguile/gc.h"	/* Everyone allocates.  */
#include "libguile/gsubr.h"	/* Everyone defines global functions.  */
#include "libguile/procs.h"	/* Same.  */
#include "libguile/numbers.h"	/* Everyone deals with fixnums.  */
#include "libguile/symbols.h"	/* For length, chars, values, miscellany.  */
#include "libguile/boolean.h"	/* Everyone wonders about the truth.  */
#include "libguile/threads.h"	/* You are not alone. */
#include "libguile/snarf.h"	/* Everyone snarfs. */
#include "libguile/variable.h"
#include "libguile/modules.h"
#include "libguile/inline.h"

#ifndef SCM_SYSCALL
#ifdef vms
# ifndef __GNUC__
#  include <ssdef.h>
#  define SCM_SYSCALL(line) do{errno = 0;line;} \
	while(EVMSERR==errno && (vaxc$errno>>3)==(SS$_CONTROLC>>3))
# endif /* ndef __GNUC__ */
#endif /* def vms */
#endif /* ndef SCM_SYSCALL  */

#ifndef SCM_SYSCALL
# ifdef EINTR
#  if (EINTR > 0)
#   define SCM_SYSCALL(line) do{errno = 0;line;}while(EINTR==errno)
#  endif /*  (EINTR > 0) */
# endif /* def EINTR */
#endif /* ndef SCM_SYSCALL */

#ifndef SCM_SYSCALL
# define SCM_SYSCALL(line) line;
#endif /* ndef SCM_SYSCALL */

#ifndef min
#define min(A, B) ((A) <= (B) ? (A) : (B))
#endif
#ifndef max
#define max(A, B) ((A) >= (B) ? (A) : (B))
#endif

#if GUILE_USE_64_CALLS && HAVE_STAT64
#define CHOOSE_LARGEFILE(foo,foo64)     foo64
#else
#define CHOOSE_LARGEFILE(foo,foo64)     foo
#endif

/* These names are a bit long, but they make it clear what they represent. */
#if SCM_HAVE_STRUCT_DIRENT64 == 1
# define dirent_or_dirent64             CHOOSE_LARGEFILE(dirent,dirent64)
#else
# define dirent_or_dirent64             dirent
#endif
#define fstat_or_fstat64                CHOOSE_LARGEFILE(fstat,fstat64)
#define ftruncate_or_ftruncate64        CHOOSE_LARGEFILE(ftruncate,ftruncate64)
#define lseek_or_lseek64                CHOOSE_LARGEFILE(lseek,lseek64)
#define lstat_or_lstat64                CHOOSE_LARGEFILE(lstat,lstat64)
#define off_t_or_off64_t                CHOOSE_LARGEFILE(off_t,off64_t)
#define open_or_open64                  CHOOSE_LARGEFILE(open,open64)
#define readdir_or_readdir64            CHOOSE_LARGEFILE(readdir,readdir64)
#if SCM_HAVE_READDIR64_R == 1
# define readdir_r_or_readdir64_r       CHOOSE_LARGEFILE(readdir_r,readdir64_r)
#else
# define readdir_r_or_readdir64_r       readdir_r
#endif
#define stat_or_stat64                  CHOOSE_LARGEFILE(stat,stat64)
#define truncate_or_truncate64          CHOOSE_LARGEFILE(truncate,truncate64)
#define scm_from_off_t_or_off64_t       CHOOSE_LARGEFILE(scm_from_off_t,scm_from_int64)
#define scm_from_ino_t_or_ino64_t       CHOOSE_LARGEFILE(scm_from_ulong,scm_from_uint64)
#define scm_from_blkcnt_t_or_blkcnt64_t CHOOSE_LARGEFILE(scm_from_ulong,scm_from_uint64)
#define scm_to_off_t_or_off64_t         CHOOSE_LARGEFILE(scm_to_off_t,scm_to_int64)

#if SIZEOF_OFF_T == 4
#  define scm_to_off_t    scm_to_int32
#  define scm_from_off_t  scm_from_int32
#elif SIZEOF_OFF_T == 8
#  define scm_to_off_t    scm_to_int64
#  define scm_from_off_t  scm_from_int64
#else
#  error sizeof(off_t) is not 4 or 8.
#endif
#define scm_to_off64_t    scm_to_int64
#define scm_from_off64_t  scm_from_int64

#endif  /* SCM__SCM_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1995, 96, 97, 98, 99, 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

#include "libguile/_scm.h"
#include "libguile/eq.h"
#include "libguile/list.h"
#include "libguile/lang.h"

#include "libguile/validate.h"
#include "libguile/pairs.h"
#include "libguile/alist.h"

SCM_DEFINE (scm_acons, "acons", 3, 0, 0,
           (SCM key, SCM value, SCM alist),
	    "Add a new key-value pair to @var{alist}.  A new pair is\n"
	    "created whose car is @var{key} and whose cdr is @var{value}, and the\n"
	    "pair is consed onto @var{alist}, and the new list is returned.  This\n"
	    "function is @emph{not} destructive; @var{alist} is not modified.")
#define FUNC_NAME s_scm_acons
{
  return scm_cell (SCM_UNPACK (scm_cell (SCM_UNPACK (key),
					 SCM_UNPACK (value))),
		   SCM_UNPACK (alist));
}
#undef FUNC_NAME

SCM_DEFINE (scm_sloppy_assq, "sloppy-assq", 2, 0, 0,
            (SCM key, SCM alist),
	    "Behaves like @code{assq} but does not do any error checking.\n"
	    "Recommended only for use in Guile internals.")
#define FUNC_NAME s_scm_sloppy_assq
{
  for (; scm_is_pair (alist); alist = SCM_CDR (alist))
    {
      SCM tmp = SCM_CAR (alist);
      if (scm_is_pair (tmp) && scm_is_eq (SCM_CAR (tmp), key))
	return tmp;
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_sloppy_assv, "sloppy-assv", 2, 0, 0,
            (SCM key, SCM alist),
	    "Behaves like @code{assv} but does not do any error checking.\n"
	    "Recommended only for use in Guile internals.")
#define FUNC_NAME s_scm_sloppy_assv
{
  for (; scm_is_pair (alist); alist = SCM_CDR (alist))
    {
      SCM tmp = SCM_CAR (alist);
      if (scm_is_pair (tmp)
	  && scm_is_true (scm_eqv_p (SCM_CAR (tmp), key)))
	return tmp;
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_sloppy_assoc, "sloppy-assoc", 2, 0, 0,
            (SCM key, SCM alist),
	    "Behaves like @code{assoc} but does not do any error checking.\n"
	    "Recommended only for use in Guile internals.")
#define FUNC_NAME s_scm_sloppy_assoc
{
  for (; scm_is_pair (alist); alist = SCM_CDR (alist))
    {
      SCM tmp = SCM_CAR (alist);
      if (scm_is_pair (tmp)
	  && scm_is_true (scm_equal_p (SCM_CAR (tmp), key)))
	return tmp;
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_assq, "assq", 2, 0, 0,
           (SCM key, SCM alist),
	    "@deffnx {Scheme Procedure} assv key alist\n"
	    "@deffnx {Scheme Procedure} assoc key alist\n"
	    "Fetch the entry in @var{alist} that is associated with @var{key}.  To\n"
	    "decide whether the argument @var{key} matches a particular entry in\n"
	    "@var{alist}, @code{assq} compares keys with @code{eq?}, @code{assv}\n"
	    "uses @code{eqv?} and @code{assoc} uses @code{equal?}.  If @var{key}\n"
	    "cannot be found in @var{alist} (according to whichever equality\n"
	    "predicate is in use), then return @code{#f}.  These functions\n"
	    "return the entire alist entry found (i.e. both the key and the value).")
#define FUNC_NAME s_scm_assq
{
  SCM ls = alist;
  for(; scm_is_pair (ls); ls = SCM_CDR (ls))
    {
      SCM tmp = SCM_CAR (ls);
      SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
		       "association list");
      if (scm_is_eq (SCM_CAR (tmp), key))
	return tmp;
    }
  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
		   "association list");
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_assv, "assv", 2, 0, 0,
           (SCM key, SCM alist),
	    "Behaves like @code{assq} but uses @code{eqv?} for key comparison.")
#define FUNC_NAME s_scm_assv
{
  SCM ls = alist;
  for(; scm_is_pair (ls); ls = SCM_CDR (ls))
    {
      SCM tmp = SCM_CAR (ls);
      SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
		       "association list");
      if (scm_is_true (scm_eqv_p (SCM_CAR (tmp), key)))
	return tmp;
    }
  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
		   "association list");
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_assoc, "assoc", 2, 0, 0,
           (SCM key, SCM alist),
	    "Behaves like @code{assq} but uses @code{equal?} for key comparison.")
#define FUNC_NAME s_scm_assoc
{
  SCM ls = alist;
  for(; scm_is_pair (ls); ls = SCM_CDR (ls))
    {
      SCM tmp = SCM_CAR (ls);
      SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
		       "association list");
      if (scm_is_true (scm_equal_p (SCM_CAR (tmp), key)))
	return tmp;
    }
  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
		   "association list");
  return SCM_BOOL_F;
}
#undef FUNC_NAME

/* Dirk:API2.0:: We should not return #f if the key was not found.  In the
 * current solution we can not distinguish between finding a (key . #f) pair
 * and not finding the key at all.
 *
 * Possible alternative solutions:
 * 1) Remove assq-ref from the API:  assq is sufficient.
 * 2) Signal an error (what error type?) if the key is not found.
 * 3) provide an additional 'default' parameter.
 * 3.1) The default parameter is mandatory.
 * 3.2) The default parameter is optional, but if no default is given and
 *      the key is not found, signal an error (what error type?).
 */
SCM_DEFINE (scm_assq_ref, "assq-ref", 2, 0, 0,
            (SCM alist, SCM key),
	    "@deffnx {Scheme Procedure} assv-ref alist key\n"
	    "@deffnx {Scheme Procedure} assoc-ref alist key\n"
	    "Like @code{assq}, @code{assv} and @code{assoc}, except that only the\n"
	    "value associated with @var{key} in @var{alist} is returned.  These\n"
	    "functions are equivalent to\n\n"
	    "@lisp\n"
	    "(let ((ent (@var{associator} @var{key} @var{alist})))\n"
	    "  (and ent (cdr ent)))\n"
	    "@end lisp\n\n"
	    "where @var{associator} is one of @code{assq}, @code{assv} or @code{assoc}.")
#define FUNC_NAME s_scm_assq_ref
{
  SCM handle;

  handle = scm_sloppy_assq (key, alist);
  if (scm_is_pair (handle))
    {
      return SCM_CDR (handle);
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_assv_ref, "assv-ref", 2, 0, 0,
            (SCM alist, SCM key),
	    "Behaves like @code{assq-ref} but uses @code{eqv?} for key comparison.")
#define FUNC_NAME s_scm_assv_ref
{
  SCM handle;

  handle = scm_sloppy_assv (key, alist);
  if (scm_is_pair (handle))
    {
      return SCM_CDR (handle);
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_assoc_ref, "assoc-ref", 2, 0, 0,
            (SCM alist, SCM key),
	    "Behaves like @code{assq-ref} but uses @code{equal?} for key comparison.")
#define FUNC_NAME s_scm_assoc_ref
{
  SCM handle;

  handle = scm_sloppy_assoc (key, alist);
  if (scm_is_pair (handle))
    {
      return SCM_CDR (handle);
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_assq_set_x, "assq-set!", 3, 0, 0,
            (SCM alist, SCM key, SCM val),
	    "@deffnx {Scheme Procedure} assv-set! alist key value\n"
	    "@deffnx {Scheme Procedure} assoc-set! alist key value\n"
	    "Reassociate @var{key} in @var{alist} with @var{value}: find any existing\n"
	    "@var{alist} entry for @var{key} and associate it with the new\n"
	    "@var{value}.  If @var{alist} does not contain an entry for @var{key},\n"
	    "add a new one.  Return the (possibly new) alist.\n\n"
	    "These functions do not attempt to verify the structure of @var{alist},\n"
	    "and so may cause unusual results if passed an object that is not an\n"
	    "association list.")
#define FUNC_NAME s_scm_assq_set_x
{
  SCM handle;

  handle = scm_sloppy_assq (key, alist);
  if (scm_is_pair (handle))
    {
      SCM_SETCDR (handle, val);
      return alist;
    }
  else
    return scm_acons (key, val, alist);
}
#undef FUNC_NAME

SCM_DEFINE (scm_assv_set_x, "assv-set!", 3, 0, 0,
            (SCM alist, SCM key, SCM val),
	    "Behaves like @code{assq-set!} but uses @code{eqv?} for key comparison.")
#define FUNC_NAME s_scm_assv_set_x
{
  SCM handle;

  handle = scm_sloppy_assv (key, alist);
  if (scm_is_pair (handle))
    {
      SCM_SETCDR (handle, val);
      return alist;
    }
  else
    return scm_acons (key, val, alist);
}
#undef FUNC_NAME

SCM_DEFINE (scm_assoc_set_x, "assoc-set!", 3, 0, 0,
            (SCM alist, SCM key, SCM val),
	    "Behaves like @code{assq-set!} but uses @code{equal?} for key comparison.")
#define FUNC_NAME s_scm_assoc_set_x
{
  SCM handle;

  handle = scm_sloppy_assoc (key, alist);
  if (scm_is_pair (handle))
    {
      SCM_SETCDR (handle, val);
      return alist;
    }
  else
    return scm_acons (key, val, alist);
}
#undef FUNC_NAME

SCM_DEFINE (scm_assq_remove_x, "assq-remove!", 2, 0, 0,
            (SCM alist, SCM key),
	    "@deffnx {Scheme Procedure} assv-remove! alist key\n"
	    "@deffnx {Scheme Procedure} assoc-remove! alist key\n"
	    "Delete the first entry in @var{alist} associated with @var{key}, and return\n"
	    "the resulting alist.")
#define FUNC_NAME s_scm_assq_remove_x
{
  SCM handle;

  handle = scm_sloppy_assq (key, alist);
  if (scm_is_pair (handle))
    alist = scm_delq1_x (handle, alist);

  return alist;
}
#undef FUNC_NAME

SCM_DEFINE (scm_assv_remove_x, "assv-remove!", 2, 0, 0,
            (SCM alist, SCM key),
	    "Behaves like @code{assq-remove!} but uses @code{eqv?} for key comparison.")
#define FUNC_NAME s_scm_assv_remove_x
{
  SCM handle;

  handle = scm_sloppy_assv (key, alist);
  if (scm_is_pair (handle))
    alist = scm_delq1_x (handle, alist);

  return alist;
}
#undef FUNC_NAME

SCM_DEFINE (scm_assoc_remove_x, "assoc-remove!", 2, 0, 0,
            (SCM alist, SCM key),
	    "Behaves like @code{assq-remove!} but uses @code{equal?} for key comparison.")
#define FUNC_NAME s_scm_assoc_remove_x
{
  SCM handle;

  handle = scm_sloppy_assoc (key, alist);
  if (scm_is_pair (handle))
    alist = scm_delq1_x (handle, alist);

  return alist;
}
#undef FUNC_NAME

void
scm_init_alist ()
{
#include "libguile/alist.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_ALIST_H
#define SCM_ALIST_H

/* Copyright (C) 1995,1996,2000, 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
 */

#include "libguile/__scm.h"

SCM_API SCM scm_acons (SCM w, SCM x, SCM y);
SCM_API SCM scm_sloppy_assq (SCM x, SCM alist);
SCM_API SCM scm_sloppy_assv (SCM x, SCM alist);
SCM_API SCM scm_sloppy_assoc (SCM x, SCM alist);
SCM_API SCM scm_assq (SCM x, SCM alist);
SCM_API SCM scm_assv (SCM x, SCM alist);
SCM_API SCM scm_assoc (SCM x, SCM alist);
SCM_API SCM scm_assq_ref (SCM alist, SCM key);
SCM_API SCM scm_assv_ref (SCM alist, SCM key);
SCM_API SCM scm_assoc_ref (SCM alist, SCM key);
SCM_API SCM scm_assq_set_x (SCM alist, SCM key, SCM val);
SCM_API SCM scm_assv_set_x (SCM alist, SCM key, SCM val);
SCM_API SCM scm_assoc_set_x (SCM alist, SCM key, SCM val);
SCM_API SCM scm_assq_remove_x (SCM alist, SCM key);
SCM_API SCM scm_assv_remove_x (SCM alist, SCM key);
SCM_API SCM scm_assoc_remove_x (SCM alist, SCM key);
SCM_API void scm_init_alist (void);

#endif  /* SCM_ALIST_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* alloca.c -- allocate automatically reclaimed memory
   (Mostly) portable public-domain implementation -- D A Gwyn

   This implementation of the PWB library alloca function,
   which is used to allocate space off the run-time stack so
   that it is automatically reclaimed upon procedure exit,
   was inspired by discussions with J. Q. Johnson of Cornell.
   J.Otto Tennant <jot@cray.com> contributed the Cray support.

   There are some preprocessor constants that can
   be defined when compiling for your specific system, for
   improved efficiency; however, the defaults should be okay.

   The general concept of this implementation is to keep
   track of all alloca-allocated blocks, and reclaim any
   that are found to be deeper in the stack than the current
   invocation.  This heuristic does not reclaim storage as
   soon as it becomes invalid, but it will do so eventually.

   As a special case, alloca(0) reclaims storage without
   allocating any.  It is a good idea to use alloca(0) in
   your main control loop, etc. to force garbage collection.  */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include "libguile/scmconfig.h"

#ifdef HAVE_STRING_H
#include <string.h>
#endif
#ifdef HAVE_STDLIB_H
#include <stdlib.h>
#endif

#ifdef emacs
#include "libguile/blockinput.h"
#endif

/* If compiling with GCC 2, this file's not needed.  */
#if !defined (__GNUC__) || __GNUC__ < 2

/* If someone has defined alloca as a macro,
   there must be some other way alloca is supposed to work.  */
#ifndef alloca

#ifdef emacs
#ifdef static
/* actually, only want this if static is defined as ""
   -- this is for usg, in which emacs must undefine static
   in order to make unexec workable
   */
#ifndef STACK_DIRECTION
you
lose
-- must know STACK_DIRECTION at compile-time
#endif /* STACK_DIRECTION undefined */
#endif /* static */
#endif /* emacs */

/* If your stack is a linked list of frames, you have to
   provide an "address metric" ADDRESS_FUNCTION macro.  */

#if defined (CRAY) && defined (CRAY_STACKSEG_END)
long i00afunc ();
#define ADDRESS_FUNCTION(arg) (char *) i00afunc (&(arg))
#else
#define ADDRESS_FUNCTION(arg) &(arg)
#endif

#if __STDC__
typedef void *pointer;
#else
typedef char *pointer;
#endif

#ifndef NULL
#define	NULL	0
#endif

/* Define STACK_DIRECTION if you know the direction of stack
   growth for your system; otherwise it will be automatically
   deduced at run-time.

   STACK_DIRECTION > 0 => grows toward higher addresses
   STACK_DIRECTION < 0 => grows toward lower addresses
   STACK_DIRECTION = 0 => direction of growth unknown  */

#ifndef STACK_DIRECTION
#define	STACK_DIRECTION	0	/* Direction unknown.  */
#endif

#if STACK_DIRECTION != 0

#define	STACK_DIR	STACK_DIRECTION	/* Known at compile-time.  */

#else /* STACK_DIRECTION == 0; need run-time code.  */

static int stack_dir;		/* 1 or -1 once known.  */
#define	STACK_DIR	stack_dir

static void
find_stack_direction ()
{
  static char *addr = NULL;	/* Address of first `dummy', once known.  */
  auto char dummy;		/* To get stack address.  */

  if (addr == NULL)
    {				/* Initial entry.  */
      addr = ADDRESS_FUNCTION (dummy);

      find_stack_direction ();	/* Recurse once.  */
    }
  else
    {
      /* Second entry.  */
      if (ADDRESS_FUNCTION (dummy) > addr)
	stack_dir = 1;		/* Stack grew upward.  */
      else
	stack_dir = -1;		/* Stack grew downward.  */
    }
}

#endif /* STACK_DIRECTION == 0 */

/* An "alloca header" is used to:
   (a) chain together all alloca'ed blocks;
   (b) keep track of stack depth.

   It is very important that sizeof(header) agree with malloc
   alignment chunk size.  The following default should work okay.  */

#ifndef	ALIGN_SIZE
#define	ALIGN_SIZE	sizeof(double)
#endif

typedef union hdr
{
  char align[ALIGN_SIZE];	/* To force sizeof(header).  */
  struct
    {
      union hdr *next;		/* For chaining headers.  */
      char *deep;		/* For stack depth measure.  */
    } h;
} header;

static header *last_alloca_header = NULL;	/* -> last alloca header.  */

/* Return a pointer to at least SIZE bytes of storage,
   which will be automatically reclaimed upon exit from
   the procedure that called alloca.  Originally, this space
   was supposed to be taken from the current stack frame of the
   caller, but that method cannot be made to work for some
   implementations of C, for example under Gould's UTX/32.  */

pointer
alloca (unsigned size)
{
  auto char probe;		/* Probes stack depth: */
  register char *depth = ADDRESS_FUNCTION (probe);

#if STACK_DIRECTION == 0
  if (STACK_DIR == 0)		/* Unknown growth direction.  */
    find_stack_direction ();
#endif

  /* Reclaim garbage, defined as all alloca'd storage that
     was allocated from deeper in the stack than currently.  */

  {
    register header *hp;	/* Traverses linked list.  */

#ifdef emacs
    BLOCK_INPUT;
#endif

    for (hp = last_alloca_header; hp != NULL;)
      if ((STACK_DIR > 0 && hp->h.deep > depth)
	  || (STACK_DIR < 0 && hp->h.deep < depth))
	{
	  register header *np = hp->h.next;

	  free ((pointer) hp);	/* Collect garbage.  */

	  hp = np;		/* -> next header.  */
	}
      else
	break;			/* Rest are not deeper.  */

    last_alloca_header = hp;	/* -> last valid storage.  */

#ifdef emacs
    UNBLOCK_INPUT;
#endif
  }

  if (size == 0)
    return NULL;		/* No allocation required.  */

  /* Allocate combined header + user data storage.  */

  {
    register pointer new = (pointer) scm_malloc (sizeof (header) + size);
    /* Address of header.  */

    if (new == 0)
      {
	write (2, "alloca emulation: out of memory\n", 32);
	abort();
      }

    ((header *) new)->h.next = last_alloca_header;
    ((header *) new)->h.deep = depth;

    last_alloca_header = (header *) new;

    /* User storage begins just after header.  */

    return (pointer) ((char *) new + sizeof (header));
  }
}

#if defined (CRAY) && defined (CRAY_STACKSEG_END)

#ifdef DEBUG_I00AFUNC
#include <stdio.h>
#endif

#ifndef CRAY_STACK
#define CRAY_STACK
#ifndef CRAY2
/* Stack structures for CRAY-1, CRAY X-MP, and CRAY Y-MP */
struct stack_control_header
  {
    long shgrow:32;		/* Number of times stack has grown.  */
    long shaseg:32;		/* Size of increments to stack.  */
    long shhwm:32;		/* High water mark of stack.  */
    long shsize:32;		/* Current size of stack (all segments).  */
  };

/* The stack segment linkage control information occurs at
   the high-address end of a stack segment.  (The stack
   grows from low addresses to high addresses.)  The initial
   part of the stack segment linkage control information is
   0200 (octal) words.  This provides for register storage
   for the routine which overflows the stack.  */

struct stack_segment_linkage
  {
    long ss[0200];		/* 0200 overflow words.  */
    long sssize:32;		/* Number of words in this segment.  */
    long ssbase:32;		/* Offset to stack base.  */
    long:32;
    long sspseg:32;		/* Offset to linkage control of previous
				   segment of stack.  */
    long:32;
    long sstcpt:32;		/* Pointer to task common address block.  */
    long sscsnm;		/* Private control structure number for
				   microtasking.  */
    long ssusr1;		/* Reserved for user.  */
    long ssusr2;		/* Reserved for user.  */
    long sstpid;		/* Process ID for pid based multi-tasking.  */
    long ssgvup;		/* Pointer to multitasking thread giveup.  */
    long sscray[7];		/* Reserved for Cray Research.  */
    long ssa0;
    long ssa1;
    long ssa2;
    long ssa3;
    long ssa4;
    long ssa5;
    long ssa6;
    long ssa7;
    long sss0;
    long sss1;
    long sss2;
    long sss3;
    long sss4;
    long sss5;
    long sss6;
    long sss7;
  };

#else /* CRAY2 */
/* The following structure defines the vector of words
   returned by the STKSTAT library routine.  */
struct stk_stat
  {
    long now;			/* Current total stack size.  */
    long maxc;			/* Amount of contiguous space which would
				   be required to satisfy the maximum
				   stack demand to date.  */
    long high_water;		/* Stack high-water mark.  */
    long overflows;		/* Number of stack overflow ($STKOFEN) calls.  */
    long hits;			/* Number of internal buffer hits.  */
    long extends;		/* Number of block extensions.  */
    long stko_mallocs;		/* Block allocations by $STKOFEN.  */
    long underflows;		/* Number of stack underflow calls ($STKRETN).  */
    long stko_free;		/* Number of deallocations by $STKRETN.  */
    long stkm_free;		/* Number of deallocations by $STKMRET.  */
    long segments;		/* Current number of stack segments.  */
    long maxs;			/* Maximum number of stack segments so far.  */
    long pad_size;		/* Stack pad size.  */
    long current_address;	/* Current stack segment address.  */
    long current_size;		/* Current stack segment size.  This
				   number is actually corrupted by STKSTAT to
				   include the fifteen word trailer area.  */
    long initial_address;	/* Address of initial segment.  */
    long initial_size;		/* Size of initial segment.  */
  };

/* The following structure describes the data structure which trails
   any stack segment.  I think that the description in 'asdef' is
   out of date.  I only describe the parts that I am sure about.  */

struct stk_trailer
  {
    long this_address;		/* Address of this block.  */
    long this_size;		/* Size of this block (does not include
				   this trailer).  */
    long unknown2;
    long unknown3;
    long link;			/* Address of trailer block of previous
				   segment.  */
    long unknown5;
    long unknown6;
    long unknown7;
    long unknown8;
    long unknown9;
    long unknown10;
    long unknown11;
    long unknown12;
    long unknown13;
    long unknown14;
  };

#endif /* CRAY2 */
#endif /* not CRAY_STACK */

#ifdef CRAY2
/* Determine a "stack measure" for an arbitrary ADDRESS.
   I doubt that "lint" will like this much.  */

static long
i00afunc (long *address)
{
  struct stk_stat status;
  struct stk_trailer *trailer;
  long *block, size;
  long result = 0;

  /* We want to iterate through all of the segments.  The first
     step is to get the stack status structure.  We could do this
     more quickly and more directly, perhaps, by referencing the
     $LM00 common block, but I know that this works.  */

  STKSTAT (&status);

  /* Set up the iteration.  */

  trailer = (struct stk_trailer *) (status.current_address
				    + status.current_size
				    - 15);

  /* There must be at least one stack segment.  Therefore it is
     a fatal error if "trailer" is null.  */

  if (trailer == 0)
    abort ();

  /* Discard segments that do not contain our argument address.  */

  while (trailer != 0)
    {
      block = (long *) trailer->this_address;
      size = trailer->this_size;
      if (block == 0 || size == 0)
	abort ();
      trailer = (struct stk_trailer *) trailer->link;
      if ((block <= address) && (address < (block + size)))
	break;
    }

  /* Set the result to the offset in this segment and add the sizes
     of all predecessor segments.  */

  result = address - block;

  if (trailer == 0)
    {
      return result;
    }

  do
    {
      if (trailer->this_size <= 0)
	abort ();
      result += trailer->this_size;
      trailer = (struct stk_trailer *) trailer->link;
    }
  while (trailer != 0);

  /* We are done.  Note that if you present a bogus address (one
     not in any segment), you will get a different number back, formed
     from subtracting the address of the first block.  This is probably
     not what you want.  */

  return (result);
}

#else /* not CRAY2 */
/* Stack address function for a CRAY-1, CRAY X-MP, or CRAY Y-MP.
   Determine the number of the cell within the stack,
   given the address of the cell.  The purpose of this
   routine is to linearize, in some sense, stack addresses
   for alloca.  */

static long
i00afunc (long address)
{
  long stkl = 0;

  long size, pseg, this_segment, stack;
  long result = 0;

  struct stack_segment_linkage *ssptr;

  /* Register B67 contains the address of the end of the
     current stack segment.  If you (as a subprogram) store
     your registers on the stack and find that you are past
     the contents of B67, you have overflowed the segment.

     B67 also points to the stack segment linkage control
     area, which is what we are really interested in.  */

  stkl = CRAY_STACKSEG_END ();
  ssptr = (struct stack_segment_linkage *) stkl;

  /* If one subtracts 'size' from the end of the segment,
     one has the address of the first word of the segment.

     If this is not the first segment, 'pseg' will be
     nonzero.  */

  pseg = ssptr->sspseg;
  size = ssptr->sssize;

  this_segment = stkl - size;

  /* It is possible that calling this routine itself caused
     a stack overflow.  Discard stack segments which do not
     contain the target address.  */

  while (!(this_segment <= address && address <= stkl))
    {
#ifdef DEBUG_I00AFUNC
      fprintf (stderr, "%011o %011o %011o\n", this_segment, address, stkl);
#endif
      if (pseg == 0)
	break;
      stkl = stkl - pseg;
      ssptr = (struct stack_segment_linkage *) stkl;
      size = ssptr->sssize;
      pseg = ssptr->sspseg;
      this_segment = stkl - size;
    }

  result = address - this_segment;

  /* If you subtract pseg from the current end of the stack,
     you get the address of the previous stack segment's end.
     This seems a little convoluted to me, but I'll bet you save
     a cycle somewhere.  */

  while (pseg != 0)
    {
#ifdef DEBUG_I00AFUNC
      fprintf (stderr, "%011o %011o\n", pseg, size);
#endif
      stkl = stkl - pseg;
      ssptr = (struct stack_segment_linkage *) stkl;
      size = ssptr->sssize;
      pseg = ssptr->sspseg;
      result += size;
    }
  return (result);
}

#endif /* not CRAY2 */
#endif /* CRAY */

#endif /* no alloca */
#endif /* not GCC version 2 */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/*	Copyright (C) 1995,1996, 1997, 2000, 2001, 2004, 2005, 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/_scm.h"
#include "libguile/ports.h"
#include "libguile/smob.h"

#include "libguile/validate.h"
#include "libguile/arbiters.h"

/* FETCH_STORE sets "fet" to the value fetched from "mem" and then stores
   "sto" there.  The fetch and store are done atomically, so once the fetch
   has been done no other thread or processor can fetch from there before
   the store is done.

   The operands are scm_t_bits, fet and sto are plain variables, mem is a
   memory location (ie. an lvalue).

   ENHANCE-ME: Add more cpu-specifics.  glibc atomicity.h has some of the
   sort of thing required.  FETCH_STORE could become some sort of
   compare-and-store if that better suited what various cpus do.  */

#if defined (__GNUC__) && defined (i386) && SIZEOF_SCM_T_BITS == 4
/* This is for i386 with the normal 32-bit scm_t_bits.  The xchg instruction
   is atomic on a single processor, and it automatically asserts the "lock"
   bus signal so it's atomic on a multi-processor (no need for the lock
   prefix on the instruction).

   The mem operand is read-write but "+" is not used since old gcc
   (eg. 2.7.2) doesn't support that.  "1" for the mem input doesn't work
   (eg. gcc 3.3) when mem is a pointer dereference like current usage below.
   Having mem as a plain input should be ok though.  It tells gcc the value
   is live, but as an "m" gcc won't fetch it itself (though that would be
   harmless).  */

#define FETCH_STORE(fet,mem,sto)                \
  do {                                          \
    asm ("xchg %0, %1"                          \
         : "=r" (fet), "=m" (mem)               \
         : "0"  (sto), "m"  (mem));             \
  } while (0)
#endif

#ifndef FETCH_STORE
/* This is a generic version, with a mutex to ensure the operation is
   atomic.  Unfortunately this approach probably makes arbiters no faster
   than mutexes (though still using less memory of course), so some
   CPU-specifics are highly desirable.  */
#define FETCH_STORE(fet,mem,sto)                        \
  do {                                                  \
    scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);   \
    (fet) = (mem);                                      \
    (mem) = (sto);                                      \
    scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);     \
  } while (0)
#endif

static scm_t_bits scm_tc16_arbiter;

#define SCM_LOCK_VAL         (scm_tc16_arbiter | (1L << 16))
#define SCM_UNLOCK_VAL       scm_tc16_arbiter
#define SCM_ARB_LOCKED(arb)  ((SCM_CELL_WORD_0 (arb)) & (1L << 16))

static int
arbiter_print (SCM exp, SCM port, scm_print_state *pstate)
{
  scm_puts ("#<arbiter ", port);
  if (SCM_ARB_LOCKED (exp))
    scm_puts ("locked ", port);
  scm_iprin1 (SCM_PACK (SCM_SMOB_DATA (exp)), port, pstate);
  scm_putc ('>', port);
  return !0;
}

SCM_DEFINE (scm_make_arbiter, "make-arbiter", 1, 0, 0,
	    (SCM name),
	    "Return an arbiter object, initially unlocked.  Currently\n"
	    "@var{name} is only used for diagnostic output.")
#define FUNC_NAME s_scm_make_arbiter
{
  SCM_RETURN_NEWSMOB (scm_tc16_arbiter, SCM_UNPACK (name));
}
#undef FUNC_NAME

/* The atomic FETCH_STORE here is so two threads can't both see the arbiter
   unlocked and return #t.  The arbiter itself wouldn't be corrupted by
   this, but two threads both getting #t would be contrary to the intended
   semantics.  */

SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0,
	    (SCM arb),
	    "If @var{arb} is unlocked, then lock it and return @code{#t}.\n"
	    "If @var{arb} is already locked, then do nothing and return\n"
	    "@code{#f}.")
#define FUNC_NAME s_scm_try_arbiter
{
  scm_t_bits old;
  SCM_VALIDATE_SMOB (1, arb, arbiter);
  FETCH_STORE (old, * (scm_t_bits *) SCM_CELL_OBJECT_LOC(arb,0), SCM_LOCK_VAL);
  return scm_from_bool (old == SCM_UNLOCK_VAL);
}
#undef FUNC_NAME

/* The atomic FETCH_STORE here is so two threads can't both see the arbiter
   locked and return #t.  The arbiter itself wouldn't be corrupted by this,
   but we don't want two threads both thinking they were the unlocker.  The
   intended usage is for the code which locked to be responsible for
   unlocking, but we guarantee the return value even if multiple threads
   compete.  */

SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0,
	    (SCM arb),
	    "If @var{arb} is locked, then unlock it and return @code{#t}.\n"
	    "If @var{arb} is already unlocked, then do nothing and return\n"
	    "@code{#f}.\n"
	    "\n"
	    "Typical usage is for the thread which locked an arbiter to\n"
	    "later release it, but that's not required, any thread can\n"
	    "release it.")
#define FUNC_NAME s_scm_release_arbiter
{
  scm_t_bits old;
  SCM_VALIDATE_SMOB (1, arb, arbiter);
  FETCH_STORE (old, *(scm_t_bits*)SCM_CELL_OBJECT_LOC(arb,0), SCM_UNLOCK_VAL);
  return scm_from_bool (old == SCM_LOCK_VAL);
}
#undef FUNC_NAME

void
scm_init_arbiters ()
{
  scm_tc16_arbiter = scm_make_smob_type ("arbiter", 0);
  scm_set_smob_mark (scm_tc16_arbiter, scm_markcdr);
  scm_set_smob_print (scm_tc16_arbiter, arbiter_print);
#include "libguile/arbiters.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_ARBITERS_H
#define SCM_ARBITERS_H

/* Copyright (C) 1995,1996,2000, 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
 */

#include "libguile/__scm.h"

SCM_API SCM scm_make_arbiter (SCM name);
SCM_API SCM scm_try_arbiter (SCM arb);
SCM_API SCM scm_release_arbiter (SCM arb);
SCM_API void scm_init_arbiters (void);

#endif  /* SCM_ARBITERS_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 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

#include <signal.h>
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/throw.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/lang.h"
#include "libguile/dynwind.h"
#include "libguile/deprecation.h"

#include "libguile/validate.h"
#include "libguile/async.h"

#ifdef HAVE_STRING_H
#include <string.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

/* {Asynchronous Events}
 *
 * There are two kinds of asyncs: system asyncs and user asyncs.  The
 * two kinds have some concepts in commen but work slightly
 * differently and are not interchangeable.
 *
 * System asyncs are used to run arbitrary code at the next safe point
 * in a specified thread.  You can use them to trigger execution of
 * Scheme code from signal handlers or to interrupt a thread, for
 * example.
 *
 * Each thread has a list of 'activated asyncs', which is a normal
 * Scheme list of procedures with zero arguments.  When a thread
 * executes a SCM_ASYNC_TICK statement (which is included in
 * SCM_TICK), it will call all procedures on this list.
 *
 * Also, a thread will wake up when a procedure is added to its list
 * of active asyncs and call them.  After that, it will go to sleep
 * again.  (Not implemented yet.)
 *
 *
 * User asyncs are a little data structure that consists of a
 * procedure of zero arguments and a mark.  There are functions for
 * setting the mark of a user async and for calling all procedures of
 * marked asyncs in a given list.  Nothing you couldn't quickly
 * implement yourself.
 */

/* User asyncs. */

static scm_t_bits tc16_async;

/* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it.
   this is ugly.  */
#define SCM_ASYNCP(X)		SCM_TYP16_PREDICATE (tc16_async, X)
#define VALIDATE_ASYNC(pos, a)	SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user async")

#define ASYNC_GOT_IT(X)        (SCM_CELL_WORD_0 (X) >> 16)
#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 ((X), SCM_TYP16 (X) | ((V) << 16)))
#define ASYNC_THUNK(X)         SCM_CELL_OBJECT_1 (X)

static SCM
async_gc_mark (SCM obj)
{
  return ASYNC_THUNK (obj);
}

SCM_DEFINE (scm_async, "async", 1, 0, 0,
	    (SCM thunk),
	    "Create a new async for the procedure @var{thunk}.")
#define FUNC_NAME s_scm_async
{
  SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk));
}
#undef FUNC_NAME

SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0,
            (SCM a),
	    "Mark the async @var{a} for future execution.")
#define FUNC_NAME s_scm_async_mark
{
  VALIDATE_ASYNC (1, a);
  SET_ASYNC_GOT_IT (a, 1);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0,
	    (SCM list_of_a),
	    "Execute all thunks from the asyncs of the list @var{list_of_a}.")
#define FUNC_NAME s_scm_run_asyncs
{
  while (! SCM_NULL_OR_NIL_P (list_of_a))
    {
      SCM a;
      SCM_VALIDATE_CONS (1, list_of_a);
      a = SCM_CAR (list_of_a);
      VALIDATE_ASYNC (SCM_ARG1, a);
      if (ASYNC_GOT_IT (a))
	{
	  SET_ASYNC_GOT_IT (a, 0);
	  scm_call_0 (ASYNC_THUNK (a));
	}
      list_of_a = SCM_CDR (list_of_a);
    }
  return SCM_BOOL_T;
}
#undef FUNC_NAME

static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;

/* System asyncs. */

void
scm_async_click ()
{
  scm_i_thread *t = SCM_I_CURRENT_THREAD;
  SCM asyncs;

  /* Reset pending_asyncs even when asyncs are blocked and not really
     executed since this will avoid future futile calls to this
     function.  When asyncs are unblocked again, this function is
     invoked even when pending_asyncs is zero.
  */

  scm_i_pthread_mutex_lock (&async_mutex);
  t->pending_asyncs = 0;
  if (t->block_asyncs == 0)
    {
      asyncs = t->active_asyncs;
      t->active_asyncs = SCM_EOL;
    }
  else
    asyncs = SCM_EOL;
  scm_i_pthread_mutex_unlock (&async_mutex);

  while (scm_is_pair (asyncs))
    {
      SCM next = SCM_CDR (asyncs);
      SCM_SETCDR (asyncs, SCM_BOOL_F);
      scm_call_0 (SCM_CAR (asyncs));
      asyncs = next;
    }
}

#if (SCM_ENABLE_DEPRECATED == 1)

SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0,
            (SCM thunk),
	    "This function is deprecated.  You can use @var{thunk} directly\n"
            "instead of explicitly creating an async object.\n")
#define FUNC_NAME s_scm_system_async
{
  scm_c_issue_deprecation_warning
    ("'system-async' is deprecated.  "
     "Use the procedure directly with 'system-async-mark'.");
  return thunk;
}
#undef FUNC_NAME

#endif /* SCM_ENABLE_DEPRECATED == 1 */

void
scm_i_queue_async_cell (SCM c, scm_i_thread *t)
{
  SCM sleep_object;
  scm_i_pthread_mutex_t *sleep_mutex;
  int sleep_fd;
  SCM p;

  scm_i_pthread_mutex_lock (&async_mutex);
  p = t->active_asyncs;
  SCM_SETCDR (c, SCM_EOL);
  if (!scm_is_pair (p))
    t->active_asyncs = c;
  else
    {
      SCM pp;
      while (scm_is_pair (pp = SCM_CDR (p)))
	{
	  if (scm_is_eq (SCM_CAR (p), SCM_CAR (c)))
	    {
	      scm_i_pthread_mutex_unlock (&async_mutex);
	      return;
	    }
	  p = pp;
	}
      SCM_SETCDR (p, c);
    }
  t->pending_asyncs = 1;
  sleep_object = t->sleep_object;
  sleep_mutex = t->sleep_mutex;
  sleep_fd = t->sleep_fd;
  scm_i_pthread_mutex_unlock (&async_mutex);

  if (sleep_mutex)
    {
      /* By now, the thread T might be out of its sleep already, or
	 might even be in the next, unrelated sleep.  Interrupting it
	 anyway does no harm, however.

	 The important thing to prevent here is to signal sleep_cond
	 before T waits on it.  This can not happen since T has
	 sleep_mutex locked while setting t->sleep_mutex and will only
	 unlock it again while waiting on sleep_cond.
      */
      scm_i_scm_pthread_mutex_lock (sleep_mutex);
      scm_i_pthread_cond_signal (&t->sleep_cond);
      scm_i_pthread_mutex_unlock (sleep_mutex);
    }

  if (sleep_fd >= 0)
    {
      size_t count;
      char dummy = 0;

      /* Likewise, T might already been done with sleeping here, but
	 interrupting it once too often does no harm.  T might also
	 not yet have started sleeping, but this is no problem either
	 since the data written to a pipe will not be lost, unlike a
	 condition variable signal.  */
      count = write (sleep_fd, &dummy, 1);
    }

  /* This is needed to protect sleep_mutex.
   */
  scm_remember_upto_here_1 (sleep_object);
}

int
scm_i_setup_sleep (scm_i_thread *t,
		   SCM sleep_object, scm_i_pthread_mutex_t *sleep_mutex,
		   int sleep_fd)
{
  int pending;

  scm_i_pthread_mutex_lock (&async_mutex);
  pending = t->pending_asyncs;
  if (!pending)
    {
      t->sleep_object = sleep_object;
      t->sleep_mutex = sleep_mutex;
      t->sleep_fd = sleep_fd;
    }
  scm_i_pthread_mutex_unlock (&async_mutex);
  return pending;
}

void
scm_i_reset_sleep (scm_i_thread *t)
{
  scm_i_pthread_mutex_lock (&async_mutex);
  t->sleep_object = SCM_BOOL_F;
  t->sleep_mutex = NULL;
  t->sleep_fd = -1;
  scm_i_pthread_mutex_unlock (&async_mutex);
}

SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0,
           (SCM proc, SCM thread),
	    "Mark @var{proc} (a procedure with zero arguments) for future execution\n"
	    "in @var{thread}.  If @var{proc} has already been marked for\n"
	    "@var{thread} but has not been executed yet, this call has no effect.\n"
	    "If @var{thread} is omitted, the thread that called\n"
	    "@code{system-async-mark} is used.\n\n"
	    "This procedure is not safe to be called from C signal handlers.  Use\n"
	    "@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install\n"
	    "signal handlers.")
#define FUNC_NAME s_scm_system_async_mark_for_thread
{
  /* The current thread might not have a handle yet.  This can happen
     when the GC runs immediately before allocating the handle.  At
     the end of that GC, a system async might be marked.  Thus, we can
     not use scm_current_thread here.
  */

  scm_i_thread *t;

  if (SCM_UNBNDP (thread))
    t = SCM_I_CURRENT_THREAD;
  else
    {
      SCM_VALIDATE_THREAD (2, thread);
      if (scm_c_thread_exited_p (thread))
	SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
      t = SCM_I_THREAD_DATA (thread);
    }
  scm_i_queue_async_cell (scm_cons (proc, SCM_BOOL_F), t);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM
scm_system_async_mark (SCM proc)
#define FUNC_NAME s_scm_system_async_mark_for_thread
{
  return scm_system_async_mark_for_thread (proc, SCM_UNDEFINED);
}
#undef FUNC_NAME

SCM_DEFINE (scm_noop, "noop", 0, 0, 1,
	    (SCM args),
	    "Do nothing.  When called without arguments, return @code{#f},\n"
	    "otherwise return the first argument.")
#define FUNC_NAME s_scm_noop
{
  SCM_VALIDATE_REST_ARGUMENT (args);
  return (SCM_NULL_OR_NIL_P (args) ? SCM_BOOL_F : SCM_CAR (args));
}
#undef FUNC_NAME

#if (SCM_ENABLE_DEPRECATED == 1)

SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0,
	    (),
	    "Unmask signals. The returned value is not specified.")
#define FUNC_NAME s_scm_unmask_signals
{
  scm_i_thread *t = SCM_I_CURRENT_THREAD;

  scm_c_issue_deprecation_warning
    ("'unmask-signals' is deprecated.  "
     "Use 'call-with-blocked-asyncs' instead.");

  if (t->block_asyncs == 0)
    SCM_MISC_ERROR ("signals already unmasked", SCM_EOL);
  t->block_asyncs = 0;
  scm_async_click ();
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0,
	    (),
	    "Mask signals. The returned value is not specified.")
#define FUNC_NAME s_scm_mask_signals
{
  scm_i_thread *t = SCM_I_CURRENT_THREAD;

  scm_c_issue_deprecation_warning
    ("'mask-signals' is deprecated.  Use 'call-with-blocked-asyncs' instead.");

  if (t->block_asyncs > 0)
    SCM_MISC_ERROR ("signals already masked", SCM_EOL);
  t->block_asyncs = 1;
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

#endif /* SCM_ENABLE_DEPRECATED == 1 */

static void
increase_block (void *data)
{
  ((scm_i_thread *)data)->block_asyncs++;
}

static void
decrease_block (void *data)
{
  if (--((scm_i_thread *)data)->block_asyncs == 0)
    scm_async_click ();
}

SCM_DEFINE (scm_call_with_blocked_asyncs, "call-with-blocked-asyncs", 1, 0, 0,
	    (SCM proc),
	    "Call @var{proc} with no arguments and block the execution\n"
	    "of system asyncs by one level for the current thread while\n"
	    "it is running.  Return the value returned by @var{proc}.\n")
#define FUNC_NAME s_scm_call_with_blocked_asyncs
{
  return scm_internal_dynamic_wind (increase_block,
				    (scm_t_inner) scm_call_0,
				    decrease_block,
				    (void *)proc,
				    SCM_I_CURRENT_THREAD);
}
#undef FUNC_NAME

void *
scm_c_call_with_blocked_asyncs (void *(*proc) (void *data), void *data)
{
  return (void *)scm_internal_dynamic_wind (increase_block,
					    (scm_t_inner) proc,
					    decrease_block,
					    data,
					    SCM_I_CURRENT_THREAD);
}

SCM_DEFINE (scm_call_with_unblocked_asyncs, "call-with-unblocked-asyncs", 1, 0, 0,
	    (SCM proc),
	    "Call @var{proc} with no arguments and unblock the execution\n"
	    "of system asyncs by one level for the current thread while\n"
	    "it is running.  Return the value returned by @var{proc}.\n")
#define FUNC_NAME s_scm_call_with_unblocked_asyncs
{
  if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
    SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL);
  return scm_internal_dynamic_wind (decrease_block,
				    (scm_t_inner) scm_call_0,
				    increase_block,
				    (void *)proc,
				    SCM_I_CURRENT_THREAD);
}
#undef FUNC_NAME

void *
scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data)
{
  if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
    scm_misc_error ("scm_c_call_with_unblocked_asyncs",
		    "asyncs already unblocked", SCM_EOL);
  return (void *)scm_internal_dynamic_wind (decrease_block,
					    (scm_t_inner) proc,
					    increase_block,
					    data,
					    SCM_I_CURRENT_THREAD);
}

void
scm_dynwind_block_asyncs ()
{
  scm_i_thread *t = SCM_I_CURRENT_THREAD;
  scm_dynwind_rewind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
  scm_dynwind_unwind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
}

void
scm_dynwind_unblock_asyncs ()
{
  scm_i_thread *t = SCM_I_CURRENT_THREAD;
  if (t->block_asyncs == 0)
    scm_misc_error ("scm_with_unblocked_asyncs",
		    "asyncs already unblocked", SCM_EOL);
  scm_dynwind_rewind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
  scm_dynwind_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
}

void
scm_init_async ()
{
  scm_asyncs = SCM_EOL;
  tc16_async = scm_make_smob_type ("async", 0);
  scm_set_smob_mark (tc16_async, async_gc_mark);

#include "libguile/async.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/